-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private math math.private sequences
-sequences.private ;
+USING: accessors kernel kernel.private math math.private
+sequences sequences.private ;
IN: arrays
M: array clone (clone) ;
-M: array length array-capacity ;
+M: array length length>> ;
M: array nth-unsafe >r >fixnum r> array-nth ;
M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
M: array resize resize-array ;
] [
3dup nth-unsafe at*
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
- ] if ; inline
+ ] if ; inline recursive
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
: zip ( keys values -- alist )
2array flip ; inline
+: unzip ( assoc -- keys values )
+ dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
+
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
-: (search) ( quot seq -- i elt )
+: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
} case
- ] if ; inline
+ ] if ; inline recursive
PRIVATE>
array? hashtable? vector?
tuple? sbuf? node? tombstone?
- array-capacity array-nth set-array-nth
+ array-nth set-array-nth
wrap probe
classes classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots classes.union classes.intersection classes.predicate
-compiler.units bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
{ "imaginary" { "real" "math" } read-only }
} define-builtin
-"array" "arrays" create { } define-builtin
+"array" "arrays" create {
+ { "length" { "array-capacity" "sequences.private" } read-only }
+} define-builtin
"wrapper" "kernel" create {
{ "wrapped" read-only }
{ "sub-primitive" read-only }
} define-builtin
-"byte-array" "byte-arrays" create { } define-builtin
+"byte-array" "byte-arrays" create {
+ { "length" { "array-capacity" "sequences.private" } read-only }
+} define-builtin
"callstack" "kernel" create { } define-builtin
} prepare-slots define-tuple-class
"curry" "kernel" lookup
-[ f "inline" set-word-prop ]
-[ ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri
+{
+ [ f "inline" set-word-prop ]
+ [ make-flushable ]
+ [ ]
+ [ tuple-layout [ <tuple-boa> ] curry ]
+} cleave
(( obj quot -- curry )) define-declared
"compose" "kernel" create
} prepare-slots define-tuple-class
"compose" "kernel" lookup
-[ f "inline" set-word-prop ]
-[ ]
-[ tuple-layout [ <tuple-boa> ] curry ] tri
+{
+ [ f "inline" set-word-prop ]
+ [ make-flushable ]
+ [ ]
+ [ tuple-layout [ <tuple-boa> ] curry ]
+} cleave
(( quot1 quot2 -- compose )) define-declared
! Sub-primitive words
"libc" require
"io.streams.c" require
- "io.thread" require
"vocabs.loader" require
"syntax" require
"-no-crossref" cli-args member? [ do-crossref ] unless
+"io.thread" require
+
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
"flushable"
"foldable"
"inline"
+ "recursive"
"parsing"
"t"
"{"
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien.accessors sequences
+USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ;
IN: byte-arrays
M: byte-array clone (clone) ;
-M: byte-array length array-capacity ;
+M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
- 2dup array-capacity fixnum<
+ 2dup 1 slot fixnum<
[ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: <buckets> ( initial length -- array )
next-power-of-2 swap [ nip clone ] curry map ;
-: distribute-buckets ( assoc initial quot -- buckets )
- spin [ length <buckets> ] keep
- [ >r 2dup r> dup first roll call (distribute-buckets) ] each
- nip ; inline
+: distribute-buckets ( alist initial quot -- buckets )
+ swapd [ >r dup first r> call 2array ] curry map
+ [ length <buckets> dup ] keep
+ [ first2 (distribute-buckets) ] with each ; inline
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ peek-back ] [ pop-back* ] bi ;
: slurp-dequeue ( dequeue quot -- )
- over dequeue-empty? [ 2drop ] [
- [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
- ] if ; inline
+ [ drop [ dequeue-empty? not ] curry ]
+ [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
MIXIN: dequeue
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ;
-: (dlist-find-node) ( dlist-node quot -- node/f ? )
+: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
- ] [ 2drop f f ] if ; inline
+ ] [ 2drop f f ] if ; inline recursive
: dlist-find-node ( dlist quot -- node/f ? )
>r front>> r> (dlist-find-node) ; inline
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
-combinators accessors ;
+combinators accessors arrays ;
IN: effects
TUPLE: effect in out terminated? ;
[ t ]
} cond 2nip ;
-GENERIC: (stack-picture) ( obj -- str )
-M: string (stack-picture) ;
-M: word (stack-picture) name>> ;
-M: integer (stack-picture) drop "object" ;
+GENERIC: effect>string ( obj -- str )
+M: string effect>string ;
+M: word effect>string name>> ;
+M: integer effect>string drop "object" ;
+M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
- [ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
+ [ [ effect>string % CHAR: \s , ] each ] "" make ;
-: effect>string ( effect -- string )
+M: effect effect>string ( effect -- string )
[
"( " %
[ in>> stack-picture % "-- " % ]
M: effect clone
[ in>> clone ] [ out>> clone ] bi <effect> ;
+: stack-height ( word -- n )
+ stack-effect effect-height ;
+
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: lexer sets sequences kernel splitting effects ;
+USING: lexer sets sequences kernel splitting effects summary
+combinators debugger arrays parser ;
IN: effects.parser
-: parse-effect ( end -- effect )
- parse-tokens dup { "(" "((" } intersect empty? [
- { "--" } split1 dup [
- <effect>
- ] [
- "Stack effect declaration must contain --" throw
+DEFER: parse-effect
+
+ERROR: bad-effect ;
+
+M: bad-effect summary
+ drop "Bad stack effect declaration" ;
+
+: parse-effect-token ( end -- token/f )
+ scan tuck = [ drop f ] [
+ dup { f "(" "((" } member? [ bad-effect ] [
+ ":" ?tail [
+ scan-word {
+ { \ ( [ ")" parse-effect ] }
+ [ ]
+ } case 2array
+ ] when
] if
- ] [
- "Stack effect declaration must not contain ( or ((" throw
] if ;
+
+: parse-effect-tokens ( end -- tokens )
+ [ parse-effect-token dup ] curry [ ] [ drop ] produce ;
+
+: parse-effect ( end -- effect )
+ parse-effect-tokens { "--" } split1 dup
+ [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
+M: method-body inline?
+ "method-generic" word-prop inline? ;
+
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
+M: engine-word inline?
+ "tuple-dispatch-generic" word-prop inline? ;
+
M: engine-word crossref? "forgotten" word-prop not ;
M: engine-word irrelevant? drop t ;
SYMBOL: previous
-: (closure) ( obj quot -- )
+: (closure) ( obj quot: ( elt -- assoc ) -- )
over previous get key? [
2drop
] [
over previous get conjoin
dup slip
[ nip (closure) ] curry assoc-each
- ] if ; inline
+ ] if ; inline recursive
: closure ( obj quot -- assoc )
H{ } clone [
<PRIVATE
: wrap ( i array -- n )
- array-capacity 1 fixnum-fast fixnum-bitand ; inline
+ length>> 1 fixnum-fast fixnum-bitand ; inline
: hash@ ( key array -- i )
>r hashcode >fixnum dup fixnum+fast r> wrap ; inline
dup ((empty)) eq?
[ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if
- ] if ; inline
+ ] if ; inline recursive
: key@ ( key hash -- array n ? )
- array>> dup array-capacity 0 eq?
+ array>> dup length>> 0 eq?
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
] [
probe (new-key@)
] if
- ] if ; inline
+ ] if ; inline recursive
: new-key@ ( key hash -- array n empty? )
array>> 2dup hash@ (new-key@) ; inline
: hash-large? ( hash -- ? )
[ count>> 3 fixnum*fast 1 fixnum+fast ]
- [ array>> array-capacity ] bi fixnum> ; inline
+ [ array>> length>> ] bi fixnum> ; inline
: hash-stale? ( hash -- ? )
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
[ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
- #! last is a quotation which provides a #return or a #values
+ #! last -> #return or #values
+ #! node -> #if or #dispatch
1 reify-curries
call dup node,
pop-d drop
[ { ascii } declare decode-char ] \ decode-char inlined?
] unit-test
+[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
+
! Later
! [ t ] [
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
-TUPLE: #merge < node ;
+! Phi node: merging is a sequence of sequences of values
+TUPLE: #merge < node merging ;
: #merge ( -- node ) \ #merge all-out-node ;
: #drop ( n -- #shuffle )
d-tail flatten-curries \ #shuffle in-node ;
-: node-exists? ( node quot -- ? )
+: node-exists? ( node quot: ( node -- ? ) -- ? )
over [
2dup 2slip rot [
2drop t
] if
] [
2drop f
- ] if ; inline
+ ] if ; inline recursive
GENERIC: calls-label* ( label node -- ? )
: iterate-next ( -- node ) node@ successor>> ;
-: iterate-nodes ( node quot -- )
+: iterate-nodes ( node quot: ( -- ) -- )
over [
[ swap >node call node> drop ] keep iterate-nodes
] [
2drop
- ] if ; inline
+ ] if ; inline recursive
-: (each-node) ( quot -- next )
+: (each-node) ( quot: ( node -- ) -- next )
node@ [ swap call ] 2keep
node-children [
[
[ (each-node) ] keep swap
] iterate-nodes
] each drop
- iterate-next ; inline
+ iterate-next ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
2drop
] if ; inline
-: (transform-nodes) ( prev node quot -- )
+: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
dup >r call dup [
>>successor
successor>> dup successor>>
r> (transform-nodes)
] [
r> 2drop f >>successor drop
- ] if ; inline
+ ] if ; inline recursive
: transform-nodes ( node quot -- new-node )
over [
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel words sequences generic math
-namespaces quotations assocs combinators math.bitfields
+namespaces quotations assocs combinators
inference.backend inference.dataflow inference.state
classes.tuple classes.tuple.private effects summary hashtables
classes generic sets definitions generic.standard slots.private ;
\ spread [ spread>quot ] 1 define-transform
-! Bitfields
-GENERIC: (bitfield-quot) ( spec -- quot )
-
-M: integer (bitfield-quot) ( spec -- quot )
- [ swapd shift bitor ] curry ;
-
-M: pair (bitfield-quot) ( spec -- quot )
- first2 over word? [ >r swapd execute r> ] [ ] ?
- [ shift bitor ] append 2curry ;
-
-: bitfield-quot ( spec -- quot )
- [ (bitfield-quot) ] map [ 0 ] prefix concat ;
-
-\ bitfield [ bitfield-quot ] 1 define-transform
-
-\ flags [
- [ 0 , [ , \ bitor , ] each ] [ ] make
-] 1 define-transform
-
! Tuple operations
: [get-slots] ( slots -- quot )
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
{ CHAR: \n [ line-ends\n ] }
} case ; inline
-: ((read-until)) ( buf quot -- string/f sep/f )
- ! quot: -- char stop?
+: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
dup call
[ >r drop "" like r> ]
- [ pick push ((read-until)) ] if ; inline
+ [ pick push ((read-until)) ] if ; inline recursive
: (read-until) ( quot -- string/f sep/f )
100 <sbuf> swap ((read-until)) ; inline
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
-: while ( pred body tail -- )
+: loop ( pred: ( -- ? ) -- )
+ dup slip swap [ loop ] [ drop ] if ; inline recursive
+
+: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
>r >r dup slip r> r> roll
[ >r tuck 2slip r> while ]
- [ 2nip call ] if ; inline
+ [ 2nip call ] if ; inline recursive
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
] recover ;
: until-quit ( -- )
- quit-flag get
- [ quit-flag off ]
- [ listen until-quit ] if ; inline
+ quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
+
+[ 0 ] [ { } bitfield-quot call ] unit-test
+
+[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
+
+[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
+
+[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
+
+[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences words ;
+USING: arrays kernel math sequences words
+namespaces inference.transforms ;
IN: math.bitfields
GENERIC: (bitfield) ( value accum shift -- newaccum )
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;
+
+GENERIC: (bitfield-quot) ( spec -- quot )
+
+M: integer (bitfield-quot) ( spec -- quot )
+ [ swapd shift bitor ] curry ;
+
+M: pair (bitfield-quot) ( spec -- quot )
+ first2 over word? [ >r swapd execute r> ] [ ] ?
+ [ shift bitor ] append 2curry ;
+
+: bitfield-quot ( spec -- quot )
+ [ (bitfield-quot) ] map [ 0 ] prefix concat ;
+
+\ bitfield [ bitfield-quot ] 1 define-transform
+
+\ flags [
+ [ 0 , [ , \ bitor , ] each ] [ ] make
+] 1 define-transform
: (fixnum-log2) ( accum n -- accum )
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
- inline
+ inline recursive
M: fixnum (log2) 0 swap (fixnum-log2) ;
PRIVATE>
-: (each-integer) ( i n quot -- )
+: (each-integer) ( i n quot: ( i -- ) -- )
[ iterate-step iterate-next (each-integer) ]
- [ 3drop ] if-iterate? ; inline
+ [ 3drop ] if-iterate? ; inline recursive
-: (find-integer) ( i n quot -- i )
+: (find-integer) ( i n quot: ( i -- ? ) -- i )
[
iterate-step roll
[ 2drop ] [ iterate-next (find-integer) ] if
- ] [ 3drop f ] if-iterate? ; inline
+ ] [ 3drop f ] if-iterate? ; inline recursive
-: (all-integers?) ( i n quot -- ? )
+: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
[
iterate-step roll
[ iterate-next (all-integers?) ] [ 3drop f ] if
- ] [ 3drop t ] if-iterate? ; inline
+ ] [ 3drop t ] if-iterate? ; inline recursive
: each-integer ( n quot -- )
iterate-prep (each-integer) ; inline
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
-: find-last-integer ( n quot -- i )
+: find-last-integer ( n quot: ( i -- ? ) -- i )
over 0 < [
2drop f
] [
] [
>r 1- r> find-last-integer
] if
- ] if ; inline
+ ] if ; inline recursive
[ "-101.0e-2" string>number number>string ]
unit-test
-[ 5.0 ]
-[ "10.0/2" string>number ]
-unit-test
-
[ f ]
[ "1e1/2" string>number ]
unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
+
+[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
+
+[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
+
+[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
+
+[ "-0.0" ] [ -0.0 number>string ] unit-test
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
+ "-" ?head dup negative? set swap
"/" split1 (base>) >r whole-part r>
- 3dup and and [ / + ] [ 3drop f ] if ;
+ 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: valid-digits? ( seq -- ? )
{
} cond ;
: string>integer ( str -- n/f )
+ "-" ?head swap
string>digits dup valid-digits?
- [ radix get digits>integer ] [ drop f ] if ;
+ [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
PRIVATE>
: base> ( str radix -- n/f )
[
- "-" ?head dup negative? set >r
- {
- { [ CHAR: / over member? ] [ string>ratio ] }
- { [ CHAR: . over member? ] [ string>float ] }
- [ string>integer ]
- } cond
- r> [ dup [ neg ] when ] when
+ CHAR: / over member? [
+ string>ratio
+ ] [
+ CHAR: . over member? [
+ string>float
+ ] [
+ string>integer
+ ] if
+ ] if
] with-radix ;
: string>number ( str -- n/f ) 10 base> ;
kernel.private sbufs growable assocs namespaces quotations
math strings combinators ;
-: (each-object) ( quot -- )
- next-object dup
- [ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline
+: (each-object) ( quot: ( obj -- ) -- )
+ [ next-object dup ] swap [ drop ] while ; inline
: each-object ( quot -- )
begin-scan (each-object) end-scan ; inline
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
-USE: prettyprint
-
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
slots.private ;
IN: quotations
+<PRIVATE
+
+: uncurry dup 3 slot swap 4 slot ; inline
+
+: uncompose dup 3 slot swap 4 slot ; inline
+
+PRIVATE>
+
M: quotation call (call) ;
-M: curry call dup 3 slot swap 4 slot call ;
+M: curry call uncurry call ;
-M: compose call dup 3 slot swap 4 slot slip call ;
+M: compose call uncompose slip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
<PRIVATE
-: array-capacity ( array -- n )
- 1 slot { array-capacity } declare ; inline
-
: array-nth ( n array -- elt )
swap 2 fixnum+fast slot ; inline
] 3keep ; inline
: (copy) ( dst i src j n -- dst )
- dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
+ dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
+ inline recursive
: prepare-subseq ( from to seq -- dst i src j n )
[ >r swap - r> new-sequence dup 0 ] 3keep
: halves ( seq -- first second )
dup midpoint@ cut-slice ;
-: binary-reduce ( seq start quot -- value )
+: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
>r >r halves r> r>
[ [ binary-reduce ] 2curry bi@ ] keep
call
- ] if ; inline
+ ] if ; inline recursive
: cut ( seq n -- before after )
[ head ] [ tail ] 2bi ;
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
-: (merge) ( merge quot -- )
+: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
over r-done? [ drop dump-l ] [
over l-done? [ drop dump-r ] [
2dup decide
[ over r-next ] [ over l-next ] if
(merge)
] if
- ] if ; inline
+ ] if ; inline recursive
: flip-accum ( merge -- )
dup [ accum>> ] [ accum1>> ] bi eq? [
[ merge ] 2curry each-chunk ; inline
: sort-loop ( merge quot -- )
- 2 swap
- [ pick seq>> length pick > ]
- [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
- [ ] while 3drop ; inline
+ [ 2 [ over seq>> length over > ] ] dip
+ [ [ 1 shift 2dup ] dip sort-pass ] curry
+ [ ] while 2drop ; inline
: each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1+ swap (split) ]
- [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline
+ [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
"POSTPONE:" [ scan-word parsed ] define-syntax
"\\" [ scan-word literalize parsed ] define-syntax
"inline" [ word make-inline ] define-syntax
+ "recursive" [ word make-recursive ] define-syntax
"foldable" [ word make-foldable ] define-syntax
"flushable" [ word make-flushable ] define-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
- >r [ [ ] [ ] while ] curry r> spawn ;
+ >r [ loop ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack r>
: make-inline ( word -- )
t "inline" set-word-prop ;
+: make-recursive ( word -- )
+ t "recursive" set-word-prop ;
+
: make-flushable ( word -- )
t "flushable" set-word-prop ;
M: word reset-word
{
"unannotated-def"
- "parsing" "inline" "foldable" "flushable"
+ "parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"constructing"
: constructor-word ( name vocab -- word )
>r "<" swap ">" 3append r> create ;
+GENERIC: inline? ( word -- ? )
+
+M: word inline? "inline" word-prop ;
+
PREDICATE: parsing-word < word "parsing" word-prop ;
: delimiter? ( obj -- ? )
! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: kernel continuations sequences namespaces fry ;\r
+USING: kernel continuations combinators sequences quotations arrays namespaces\r
+ fry summary assocs math math.order macros ;\r
\r
IN: backtrack\r
\r
SYMBOL: failure\r
\r
-: amb ( seq -- elt )\r
- failure get\r
- '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
- , continue ] callcc1 ;\r
+ERROR: amb-failure ;\r
+\r
+M: amb-failure summary drop "Backtracking failure" ;\r
\r
: fail ( -- )\r
- f amb drop ;\r
+ failure get [ continue ]\r
+ [ amb-failure ] if* ;\r
\r
: require ( ? -- )\r
[ fail ] unless ;\r
\r
+MACRO: checkpoint ( quot -- quot' )\r
+ '[ failure get ,\r
+ '[ '[ failure set , continue ] callcc0\r
+ , failure set @ ] callcc0 ] ;\r
+\r
+: number-from ( from -- from+n )\r
+ [ 1 + number-from ] checkpoint ;\r
+\r
+<PRIVATE\r
+\r
+: unsafe-number-from-to ( to from -- to from+n )\r
+ 2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
+\r
+: number-from-to ( to from -- to from+n )\r
+ 2dup < [ fail ] when unsafe-number-from-to ;\r
+\r
+: amb-integer ( seq -- int )\r
+ length 1 - 0 number-from-to nip ;\r
+\r
+MACRO: unsafe-amb ( seq -- quot )\r
+ dup length 1 =\r
+ [ first 1quotation ]\r
+ [ [ first ] [ rest ] bi\r
+ '[ , [ drop , unsafe-amb ] checkpoint ] ] if ;\r
+\r
+PRIVATE> \r
+\r
+: amb-lazy ( seq -- elt )\r
+ [ amb-integer ] [ nth ] bi ;\r
+\r
+: amb ( seq -- elt )\r
+ dup empty?\r
+ [ drop fail f ]\r
+ [ unsafe-amb ] if ; inline\r
+\r
+MACRO: amb-execute ( seq -- quot )\r
+ [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
+ '[ , 0 unsafe-number-from-to nip , case ] ;\r
+\r
+: if-amb ( true false -- )\r
+ [\r
+ [ { t f } amb ]\r
+ [ '[ @ require t ] ]\r
+ [ '[ @ f ] ]\r
+ tri* if\r
+ ] with-scope ; inline\r
+\r
: nop ;
-MACRO: amb-execute ( seq -- quot )
- [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
- '[ , amb , case ] ;
-
-: if-amb ( true false -- )
- [
- [ { t f } amb ]
- [ '[ @ require t ] ]
- [ '[ @ f ] ]
- tri* if
- ] with-scope ; inline
-
: do-something ( a b -- c )
{ + - * } amb-execute ;
] with-malloc
] with-malloc ; inline
-:: (NSFastEnumeration-each) ( object quot state stackbuf count -- )
+:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ , void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
- ] if ; inline
+ ] if ; inline recursive
: NSFastEnumeration-each ( object quot -- )
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline
: wait-for-mailbox ( mailbox timeout -- )\r
>r threads>> r> "mailbox" wait ;\r
\r
-: block-unless-pred ( mailbox timeout pred -- )\r
+: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
pick check-disposed\r
pick data>> over dlist-contains? [\r
3drop\r
] [\r
>r 2dup wait-for-mailbox r> block-unless-pred\r
- ] if ; inline\r
+ ] if ; inline recursive\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
over check-disposed\r
f mailbox-get-all-timeout ;\r
\r
: while-mailbox-empty ( mailbox quot -- )\r
- over mailbox-empty? [\r
- dup >r dip r> while-mailbox-empty\r
- ] [\r
- 2drop\r
- ] if ; inline\r
+ [ [ mailbox-empty? ] curry ] dip [ ] while ; inline\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
3dup block-unless-pred\r
} match-cond ;
[ -5 ] [
- [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
+ [ 0 [ counter ] loop ] "Counter" spawn "counter" set
{ increment 10 } "counter" get send
{ decrement 15 } "counter" get send
[ value , self , ] { } make "counter" get send
+++ /dev/null
-Eric Mertens
+++ /dev/null
-USING: accessors arrays hints kernel locals math sequences ;
-
-IN: disjoint-set
-
-<PRIVATE
-
-TUPLE: disjoint-set parents ranks counts ;
-
-: count ( a disjoint-set -- n )
- counts>> nth ; inline
-
-: add-count ( p a disjoint-set -- )
- [ count [ + ] curry ] keep counts>> swap change-nth ; inline
-
-: parent ( a disjoint-set -- p )
- parents>> nth ; inline
-
-: set-parent ( p a disjoint-set -- )
- parents>> set-nth ; inline
-
-: link-sets ( p a disjoint-set -- )
- [ set-parent ]
- [ add-count ] 3bi ; inline
-
-: rank ( a disjoint-set -- r )
- ranks>> nth ; inline
-
-: inc-rank ( a disjoint-set -- )
- ranks>> [ 1+ ] change-nth ; inline
-
-: representative? ( a disjoint-set -- ? )
- dupd parent = ; inline
-
-: representative ( a disjoint-set -- p )
- 2dup representative? [ drop ] [
- [ [ parent ] keep representative dup ] 2keep set-parent
- ] if ;
-
-: representatives ( a b disjoint-set -- r r )
- [ representative ] curry bi@ ; inline
-
-: ranks ( a b disjoint-set -- r r )
- [ rank ] curry bi@ ; inline
-
-:: branch ( a b neg zero pos -- )
- a b = zero [ a b < neg pos if ] if ; inline
-
-PRIVATE>
-
-: <disjoint-set> ( n -- disjoint-set )
- [ >array ]
- [ 0 <array> ]
- [ 1 <array> ] tri
- disjoint-set boa ;
-
-: equiv-set-size ( a disjoint-set -- n )
- [ representative ] keep count ;
-
-: equiv? ( a b disjoint-set -- ? )
- representatives = ; inline
-
-:: equate ( a b disjoint-set -- )
- a b disjoint-set representatives
- 2dup = [ 2drop ] [
- 2dup disjoint-set ranks
- [ swap ] [ over disjoint-set inc-rank ] [ ] branch
- disjoint-set link-sets
- ] if ;
-
-HINTS: equate disjoint-set ;
-HINTS: representative disjoint-set ;
-HINTS: equiv-set-size disjoint-set ;
+++ /dev/null
-An efficient implementation of the disjoint-set data structure
+++ /dev/null
-collections
--- /dev/null
+Eric Mertens
--- /dev/null
+! Copyright (C) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hints kernel locals math hashtables
+assocs ;
+
+IN: disjoint-sets
+
+TUPLE: disjoint-set
+{ parents hashtable read-only }
+{ ranks hashtable read-only }
+{ counts hashtable read-only } ;
+
+<PRIVATE
+
+: count ( a disjoint-set -- n )
+ counts>> at ; inline
+
+: add-count ( p a disjoint-set -- )
+ [ count [ + ] curry ] keep counts>> swap change-at ; inline
+
+: parent ( a disjoint-set -- p )
+ parents>> at ; inline
+
+: set-parent ( p a disjoint-set -- )
+ parents>> set-at ; inline
+
+: link-sets ( p a disjoint-set -- )
+ [ set-parent ] [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+ ranks>> at ; inline
+
+: inc-rank ( a disjoint-set -- )
+ ranks>> [ 1+ ] change-at ; inline
+
+: representative? ( a disjoint-set -- ? )
+ dupd parent = ; inline
+
+PRIVATE>
+
+GENERIC: representative ( a disjoint-set -- p )
+
+M: disjoint-set representative
+ 2dup representative? [ drop ] [
+ [ [ parent ] keep representative dup ] 2keep set-parent
+ ] if ;
+
+<PRIVATE
+
+: representatives ( a b disjoint-set -- r r )
+ [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+ [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+ a b = zero [ a b < neg pos if ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( -- disjoint-set )
+ H{ } clone H{ } clone H{ } clone disjoint-set boa ;
+
+GENERIC: add-atom ( a disjoint-set -- )
+
+M: disjoint-set add-atom
+ [ dupd parents>> set-at ]
+ [ 0 -rot ranks>> set-at ]
+ [ 1 -rot counts>> set-at ]
+ 2tri ;
+
+GENERIC: equiv-set-size ( a disjoint-set -- n )
+
+M: disjoint-set equiv-set-size [ representative ] keep count ;
+
+GENERIC: equiv? ( a b disjoint-set -- ? )
+
+M: disjoint-set equiv? representatives = ;
+
+GENERIC: equate ( a b disjoint-set -- )
+
+M:: disjoint-set equate ( a b disjoint-set -- )
+ a b disjoint-set representatives
+ 2dup = [ 2drop ] [
+ 2dup disjoint-set ranks
+ [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+ disjoint-set link-sets
+ ] if ;
--- /dev/null
+An efficient implementation of the disjoint-set data structure
--- /dev/null
+collections
\r
HELP: '[\r
{ $syntax "code... ]" }\r
-{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;\r
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }\r
+{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
ARTICLE: "fry.examples" "Examples of fried quotations"\r
-"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."\r
+"The easiest way to understand fried quotations is to look at some examples."\r
$nl\r
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"\r
{ $code "{ 10 20 30 } '[ . ] each" }\r
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"\r
"{ 10 20 30 } [ 3 5 / ] map"\r
}\r
-"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"\r
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"\r
{ $code \r
"{ 10 20 30 } [ sq ] '[ @ . ] each"\r
+ "{ 10 20 30 } [ sq ] [ call . ] curry each"\r
"{ 10 20 30 } [ sq ] [ . ] compose each"\r
"{ 10 20 30 } [ sq . ] each"\r
}\r
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"\r
"{ 8 13 14 27 } [ even? dup 5 ? ] map"\r
}\r
-"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"\r
+"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"\r
{ $code \r
"{ 10 20 30 } 1 '[ , _ / ] map"\r
+ "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"\r
"{ 10 20 30 } 1 [ swap / ] curry map"\r
"{ 10 20 30 } [ 1 swap / ] map"\r
}\r
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"\r
{ $code\r
- "[ >r X r> ]"\r
- "[ X _ ]"\r
+ "[ [ X ] dip ]"\r
+ "'[ X _ ]"\r
}\r
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
-"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."\r
-$nl\r
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"\r
+{ $code\r
+ "'[ [ , key? ] all? ] filter"\r
+ "[ [ key? ] curry all? ] curry filter"\r
+}\r
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
{ $code\r
"'[ 3 , + 4 , / ]"\r
} ;\r
\r
ARTICLE: "fry.limitations" "Fried quotation limitations"\r
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;\r
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."\r
{ $subsection "heaps" }
{ $subsection "graphs" }
{ $subsection "buffers" }
-"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
+"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
- [ (stack-picture) ] map
+ [ dup pair? [ first ] when effect>string ] map
prune natural-sort ;
: contains-funky-elements? ( element -- ? )
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
- ] [ ] [ ] while
+ ] loop
"c1" get count-down
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
- ] [ ] [ ] while
+ ] loop
"c2" get count-down
] "Monitor test thread" spawn drop
USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private
- concurrency.mailboxes classes ;
+ concurrency.mailboxes classes assocs ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
: with-dummy-client ( quot -- )
rot with-variable ; inline
-! Parsing tests
-irc-message new
- ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
- "someuser!n=user@some.where" >>prefix
- "PRIVMSG" >>command
- { "#factortest" } >>parameters
- "hi" >>trailing
-1array
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- string>irc-message f >>timestamp ] unit-test
-
-privmsg new
- ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
- "someuser!n=user@some.where" >>prefix
- "PRIVMSG" >>command
- { "#factortest" } >>parameters
- "hi" >>trailing
- "#factortest" >>name
-1array
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line f >>timestamp ] unit-test
-
{ "" } make-client dup "factorbot" set-nick current-irc-client [
{ t } [ irc> profile>> nickname>> me? ] unit-test
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
- profile>> nickname>> ] unit-test
+ profile>> nickname>> ] unit-test
{ join_ "#factortest" } [
- { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+ { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net MODE #factortest +ns"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} make-client dup "factorbot" set-nick
[ connect-irc ] keep 1 seconds sleep
- join-messages>> 5 seconds mailbox-get-timeout
+ join-messages>> 1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi ] unit-test
-! TODO: user join
-! ":somedude!n=user@isp.net JOIN :#factortest"
+
+{ +join+ "somebody" } [
+ { ":somebody!n=somebody@some.where JOIN :#factortest"
+ } make-client dup "factorbot" set-nick
+ [ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
+ [ connect-irc ]
+ [ listeners>> [ "#factortest" ] dip at
+ [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
+ [ action>> ] [ nick>> ] bi
+ ] unit-test
! TODO: channel message
-! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
+! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
! TODO: direct private message
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
\ No newline at end of file
TUPLE: irc-nick-listener < irc-listener name ;
SYMBOL: +server-listener+
+! participant modes
+SYMBOL: +operator+
+SYMBOL: +voice+
+SYMBOL: +normal+
+
+: participant-mode ( n -- mode )
+ H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
+
+! participant changed actions
+SYMBOL: +join+
+SYMBOL: +part+
+SYMBOL: +mode+
+
+! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
: <irc-server-listener> ( -- irc-server-listener )
! Message objects
! ======================================
+TUPLE: participant-changed nick action ;
+C: <participant-changed> participant-changed
+
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
: listener> ( name -- listener/f ) irc> listeners>> at ;
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
-: to-listener ( message name -- )
+GENERIC: to-listener ( message obj -- )
+
+M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless*
- [ in-messages>> mailbox-put ] [ drop ] if* ;
+ [ to-listener ] [ drop ] if* ;
+
+M: irc-listener to-listener ( message irc-listener -- )
+ in-messages>> mailbox-put ;
: remove-participant ( nick channel -- )
listener> [ participants>> delete-at ] [ drop ] if* ;
+: listeners-with-participant ( nick -- seq )
+ irc> listeners>> values
+ [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
+ with filter ;
+
: remove-participant-from-all ( nick -- )
- irc> listeners>>
- [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
- assoc-each ;
+ dup listeners-with-participant [ delete-at ] with each ;
-: add-participant ( nick mode channel -- )
+: add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ;
DEFER: me?
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
: broadcast-message-to-listeners ( message -- )
- irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
+ irc> listeners>> values [ to-listener ] with each ;
+
+GENERIC: handle-participant-change ( irc-message -- )
+
+M: join handle-participant-change ( join -- )
+ [ prefix>> parse-name +join+ <participant-changed> ]
+ [ trailing>> ] bi to-listener ;
+
+M: part handle-participant-change ( part -- )
+ [ prefix>> parse-name +part+ <participant-changed> ]
+ [ channel>> ] bi to-listener ;
+
+M: kick handle-participant-change ( kick -- )
+ [ who>> +part+ <participant-changed> ]
+ [ channel>> ] bi to-listener ;
+
+M: quit handle-participant-change ( quit -- )
+ prefix>> parse-name
+ [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
+ [ to-listener ] with each ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
- +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+ +server-listener+ listener> [ to-listener ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
name>> irc> profile>> (>>nickname) ;
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
- [ maybe-forward-join ]
- [ dup trailing>> to-listener ]
- [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
- tri ;
+ { [ maybe-forward-join ] ! keep
+ [ dup trailing>> to-listener ]
+ [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+ [ handle-participant-change ]
+ } cleave ;
M: part handle-incoming-irc ( part -- )
- [ dup channel>> to-listener ] keep
- [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
+ [ dup channel>> to-listener ]
+ [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
+ [ handle-participant-change ]
+ tri ;
M: kick handle-incoming-irc ( kick -- )
- [ dup channel>> to-listener ]
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
- tri ;
+ { [ dup channel>> to-listener ]
+ [ [ who>> ] [ channel>> ] bi remove-participant ]
+ [ handle-participant-change ]
+ [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+ } cleave ;
M: quit handle-incoming-irc ( quit -- )
- [ prefix>> parse-name remove-participant-from-all ] keep
- call-next-method ;
+ { [ dup prefix>> parse-name listeners-with-participant
+ [ to-listener ] with each ]
+ [ handle-participant-change ]
+ [ prefix>> parse-name remove-participant-from-all ]
+ [ ]
+ } cleave call-next-method ;
: >nick/mode ( string -- nick mode )
- dup first "+@" member? [ unclip ] [ f ] if ;
+ dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- )
- [ names-reply>participants ] [ channel>> listener> ] bi (>>participants) ;
+ [ names-reply>participants ] [ channel>> listener> ] bi
+ [ (>>participants) ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
GENERIC: handle-outgoing-irc ( obj -- )
-! M: irc-message handle-outgoing-irc ( irc-message -- )
-! irc-message>string irc-print ;
+M: irc-message handle-outgoing-irc ( irc-message -- )
+ irc-message>client-line irc-print ;
M: privmsg handle-outgoing-irc ( privmsg -- )
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
! Reader/Writer
! ======================================
-: irc-mailbox-get ( mailbox quot -- )
- [ 5 seconds ] dip
- '[ , , , [ mailbox-get-timeout ] dip call ]
- [ drop ] recover ; inline
-
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
irc>
- [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
+ [ [ irc-disconnected ] dip to-listener ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ]
tri ;
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- )
- irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
+ irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- )
- irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
+ irc> in-messages>> mailbox-get handle-incoming-irc ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
} cond ;
: listener-loop ( name listener -- )
- out-messages>> swap
- '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
- irc-mailbox-get ;
+ out-messages>> mailbox-get maybe-annotate-with-name
+ irc> out-messages>> mailbox-put ;
: spawn-irc-loop ( quot name -- )
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
--- /dev/null
+USING: kernel tools.test accessors arrays qualified
+ irc.messages irc.messages.private ;
+EXCLUDE: sequences => join ;
+IN: irc.messages.tests
+
+! Parsing tests
+irc-message new
+ ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+ "someuser!n=user@some.where" >>prefix
+ "PRIVMSG" >>command
+ { "#factortest" } >>parameters
+ "hi" >>trailing
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ string>irc-message f >>timestamp ] unit-test
+
+privmsg new
+ ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
+ "someuser!n=user@some.where" >>prefix
+ "PRIVMSG" >>command
+ { "#factortest" } >>parameters
+ "hi" >>trailing
+ "#factortest" >>name
+1array
+[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ parse-irc-line f >>timestamp ] unit-test
+
+join new
+ ":someuser!n=user@some.where JOIN :#factortest" >>line
+ "someuser!n=user@some.where" >>prefix
+ "JOIN" >>command
+ { } >>parameters
+ "#factortest" >>trailing
+1array
+[ ":someuser!n=user@some.where JOIN :#factortest"
+ parse-irc-line f >>timestamp ] unit-test
+
TUPLE: names-reply < irc-message who = channel ;
TUPLE: unhandled < irc-message ;
+: <irc-client-message> ( command parameters trailing -- irc-message )
+ irc-message new now >>timestamp
+ [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
+
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
: split-trailing ( string -- string string/f )
":" split1 ;
+PRIVATE>
+
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
-PRIVATE>
\r
IN: irc.ui.load\r
\r
-: file-or ( path path -- path ) over exists? ? ;\r
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
\r
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
\r
sequences strings hashtables splitting fry assocs hashtables\r
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids\r
- io io.styles namespaces calendar calendar.format\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models\r
irc.client irc.client.private irc.messages irc.messages.private\r
irc.ui.commandparser irc.ui.load ;\r
\r
\r
TUPLE: ui-window client tabs ;\r
\r
+TUPLE: irc-tab < frame listener client listmodel ;\r
+\r
: write-color ( str color -- )\r
foreground associate format ;\r
: red { 0.5 0 0 1 } ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
+: black { 0 0 0 1 } ;\r
+\r
+: colors H{ { +operator+ { 0 0.5 0 1 } }\r
+ { +voice+ { 0 0 1 1 } }\r
+ { +normal+ { 0 0 0 1 } } } ;\r
\r
: dot-or-parens ( string -- string )\r
dup empty? [ drop "." ]\r
" has left IRC" red write-color\r
trailing>> dot-or-parens red write-color ;\r
\r
+M: mode write-irc\r
+ "* " blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " blue write-color\r
+ [ mode>> write ] keep\r
+ " to " blue write-color\r
+ channel>> write ;\r
+\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
\r
[ print-irc ]\r
[ listener get write-message ] bi ;\r
\r
-: display ( stream listener -- )\r
+GENERIC: handle-inbox ( tab message -- )\r
+\r
+: filter-participants ( assoc val -- alist )\r
+ [ >alist ] dip\r
+ '[ second , = ] filter ;\r
+\r
+: update-participants ( tab -- )\r
+ [ listmodel>> ] [ listener>> participants>> ] bi\r
+ [ +operator+ filter-participants ]\r
+ [ +voice+ filter-participants ]\r
+ [ +normal+ filter-participants ] tri\r
+ append append swap set-model ;\r
+\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
+\r
+M: object handle-inbox\r
+ nip print-irc ;\r
+\r
+: display ( stream tab -- )\r
'[ , [ [ t ]\r
- [ , read-message print-irc ]\r
+ [ , dup listener>> read-message handle-inbox ]\r
[ ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
-: <irc-pane> ( listener -- pane )\r
+: <irc-pane> ( tab -- tab pane )\r
<scrolling-pane>\r
- [ <pane-stream> swap display ] keep ;\r
+ [ <pane-stream> swap display ] 2keep ;\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( page pane listener -- client editor )\r
- irc-editor new-editor\r
- swap >>listener swap <pane-stream> >>outstream\r
+: <irc-editor> ( tab pane -- tab editor )\r
+ over irc-editor new-editor\r
+ swap
listener>> >>listener swap <pane-stream> >>outstream
\r over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-TUPLE: irc-page < frame listener client ;\r
+: <irc-list> ( -- gadget model )\r
+ [ drop ]\r
+ [ first2 [ <label> ] dip >>color ]\r
+ { } <model> [ <list> ] keep ;\r
+\r
+: <irc-tab> ( listener client -- irc-tab )\r
+ irc-tab new-frame\r
+ swap client>> >>client swap >>listener\r
+ <irc-pane> [ <scroller> @center grid-add* ] keep\r
+ <irc-editor> <scroller> @bottom grid-add* ;\r
+\r
+: <irc-channel-tab> ( listener client -- irc-tab )\r
+ <irc-tab>\r
+ <irc-list> [ <scroller> @right grid-add* ] dip >>listmodel\r
+ [ update-participants ] keep ;\r
\r
-: <irc-page> ( listener client -- irc-page )\r
- irc-page new-frame\r
- swap client>> >>client swap [ >>listener ] keep\r
- [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
- [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+: <irc-server-tab> ( listener client -- irc-tab )\r
+ <irc-tab> ;\r
\r
-M: irc-page graft*\r
+M: irc-tab graft*\r
[ listener>> ] [ client>> ] bi\r
add-listener ;\r
\r
-M: irc-page ungraft*\r
+M: irc-tab ungraft*\r
[ listener>> ] [ client>> ] bi\r
remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ <irc-page> swap ] keep\r
+ [ <irc-channel-tab> swap ] keep\r
tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
: ui-connect ( profile -- ui-window )\r
<irc-client> ui-window new over >>client swap\r
[ connect-irc ]\r
- [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ [ listeners>> +server-listener+ swap at over <irc-tab>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
: server-open ( server port nick password channels -- )\r
[ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each ;\r
+ [ over join-channel ] each drop ;\r
\r
: main-run ( -- ) run-ircui ;\r
\r
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
+ basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
- >r "local-reader" word-prop r>
- read-local-quot [ set-local-value ] append ;
+ >r "local-reader" word-prop r>
+ read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
: parse-locals ( -- vars assoc )
")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
- effect-in make-locals dup push-locals ;
+ in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
-: each-bit ( n quot -- )
+: each-bit ( n quot: ( ? -- ) -- )
over 0 number= pick -1 number= or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
- ] if ; inline
+ ] if ; inline recursive
GENERIC: (^) ( x y -- z ) foldable
--- /dev/null
+
+IN: math.geometry
+
+GENERIC: width ( object -- width )
+GENERIC: height ( object -- width )
+
+GENERIC# set-x! 1 ( object x -- object )
+GENERIC# set-y! 1 ( object y -- object )
\ No newline at end of file
-USING: kernel arrays math.vectors ;
+USING: kernel arrays sequences math.vectors math.geometry accessors ;
IN: math.geometry.rect
-TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
+TUPLE: rect loc dim ;
-: <zero-rect> ( -- rect ) rect new ;
+: init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
-C: <rect> rect
+: <rect> ( loc dim -- rect ) rect boa ;
+
+: <zero-rect> ( -- rect ) rect new init-rect ;
M: array rect-loc ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
+M: rect width ( rect -- width ) dim>> first ;
+M: rect height ( rect -- height ) dim>> second ;
+
+M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
+M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
USING: classes io kernel kernel.private math.parser namespaces
optimizer prettyprint prettyprint.backend sequences words arrays
match macros assocs sequences.private generic combinators
-sorting math quotations accessors inference inference.dataflow
-optimizer.specializers ;
+sorting math quotations accessors inference inference.backend
+inference.dataflow optimizer.specializers generator ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
+SYMBOL: pass-count
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
-: dataflow>report ( node -- alist )
+: count-optimization-passes ( node n -- node n )
+ >r optimize-1
+ [ r> 1+ count-optimization-passes ] [ r> ] if ;
+
+: make-report ( word -- assoc )
[
+ word-dataflow nip 1 count-optimization-passes pass-count set
+
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
node-count set
] H{ } make-assoc ;
-: quot-optimize-report ( quot -- report )
- dataflow optimize dataflow>report ;
-
-: word-optimize-report ( word -- report )
- def>> quot-optimize-report ;
-
: report. ( report -- )
[
+ "==== Optimization passes:" print
+ pass-count get .
+ nl
+
"==== Total number of dataflow nodes:" print
node-count get .
] bind ;
: optimizer-report. ( word -- )
- word-optimize-report report. ;
+ make-report report. ;
] { } make ;
: find-source ( seq -- elt )
- [ keys ] [ values ] bi diff prune
+ unzip diff prune
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
-USING: circular disjoint-set kernel math math.ranges
+USING: circular disjoint-sets kernel math math.ranges
sequences sequences.lib ;
IN: project-euler.186
drop nip
] if ;
+: <relation> ( n -- unionfind )
+ <disjoint-set> [ [ add-atom ] curry each ] keep ;
+
: euler186 ( -- n )
- <generator> 0 1000000 <disjoint-set> (p186) ;
+ <generator> 0 1000000 <relation> (p186) ;
MAIN: euler186
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs words sequences arrays compiler\r
tools.time io.styles io prettyprint vocabs kernel sorting\r
-generator optimizer math math.order math.statistics combinators ;\r
+generator optimizer math math.order math.statistics combinators\r
+optimizer.debugger ;\r
IN: report.optimizer\r
\r
-: count-optimization-passes ( nodes n -- n )\r
- >r optimize-1\r
- [ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
-\r
: table. ( alist -- )\r
20 short tail*\r
standard-table-style\r
tri\r
] 2bi ; inline\r
\r
+: optimization-passes ( word -- n )\r
+ word-dataflow nip 1 count-optimization-passes nip ;\r
+\r
: optimizer-measurements ( -- alist )\r
all-words [ compiled>> ] filter\r
- [\r
- dup [\r
- word-dataflow nip 1 count-optimization-passes\r
- ] benchmark 2array\r
- ] { } map>assoc ;\r
+ [ dup [ optimization-passes ] benchmark 2array ] { } map>assoc ;\r
\r
: optimizer-measurements. ( alist -- )\r
{\r
dup string? swap number? or not
] [ drop f ] if ;
-: deep-each ( obj quot -- )
+: deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch?
- [ [ deep-each ] curry each ] [ 2drop ] if ; inline
+ [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
-: deep-map ( obj quot -- newobj )
+: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
[ call ] keep over branch?
- [ [ deep-map ] curry map ] [ drop ] if ; inline
+ [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
-: deep-filter ( obj quot -- seq )
+: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over >r
pusher >r deep-each r>
- r> dup branch? [ like ] [ drop ] if ; inline
+ r> dup branch? [ like ] [ drop ] if ; inline recursive
-: deep-find-from ( obj quot -- elt ? )
+: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
] [ 2drop f f ] if
- ] if ; inline
+ ] if ; inline recursive
: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
-: deep-change-each ( obj quot -- )
+: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
- ] curry change-each ] [ 2drop ] if ; inline
+ ] curry change-each ] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;
IN: sorting.insertion
<PRIVATE
-:: insert ( seq quot n -- )
+:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
n n 1- seq exchange
seq quot n 1- insert
] unless
- ] unless ; inline
+ ] unless ; inline recursive
PRIVATE>
: insertion-sort ( seq quot -- )
M: cocoa-ui-backend do-events ( -- )
[
- [
- NSApp [ dup do-event ] [ ] [ ] while drop
- ui-wait
- ] ui-try
+ [ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
TUPLE: pasteboard handle ;
i end < [
i j bitmap texture copy-pixel
bitmap texture end (copy-row)
- ] when ; inline
+ ] when ; inline recursive
:: copy-row ( i j bitmap texture width width2 -- i j )
i j bitmap texture i width + (copy-row)
: nth-gadget ( n gadget -- child ) children>> nth ;
-: new-gadget ( class -- gadget )
- new
- { 0 1 } >>orientation
- t >>visible?
- { f f } >>graft-state ; inline
+: init-gadget ( gadget -- gadget )
+ init-rect
+ { 0 1 } >>orientation
+ t >>visible?
+ { f f } >>graft-state ; inline
+
+: new-gadget ( class -- gadget ) new init-gadget ; inline
: <gadget> ( -- gadget )
gadget new-gadget ;
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
-{ $subsection track-add } ;
+{ $subsection track-add* } ;
HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
-HELP: track-add
+HELP: track-add*
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]
- [ [ alloted-dim ] [ track-pref-dims-1 ] bi v+ ]
+ [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ]
tri
set-axis ;
-: track-add ( gadget track constraint -- )
- over track-sizes push swap add-gadget drop ;
-
: track-add* ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
{ 0 0 } >>window-loc
swap >>status
swap >>title
- [ 1 track-add ] keep
+ swap 1 track-add*
dup request-focus ;
M: world layout*
HELP: gadget
{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
{ $list
- { { $link "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
- { { $link "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
- { { $link "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
- { { $link "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
- { { $link "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
- { { $link "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
- { { $link "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
- { { $link "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
- { { $link "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
- { { $link "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
- { { $link "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
+ { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
+ { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
+ { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
+ { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
+ { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+ { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
+ { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
+ { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
+ { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
+ { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+ { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
{ $notes
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs hashtables sequences
+accessors vectors combinators sets compiler.vops compiler.cfg ;
+IN: compiler.cfg.alias
+
+! Alias analysis -- must be run after compiler.cfg.stack.
+!
+! We try to eliminate redundant slot and stack
+! traffic using some simple heuristics.
+!
+! All heap-allocated objects which are loaded from the stack, or
+! other object slots are pessimistically assumed to belong to
+! the same alias class.
+!
+! Freshly-allocated objects get their own alias class.
+!
+! The data and retain stack pointer registers are treated
+! uniformly, and each one gets its own alias class.
+!
+! Simple pseudo-C example showing load elimination:
+!
+! int *x, *y, z: inputs
+! int a, b, c, d, e: locals
+!
+! Before alias analysis:
+!
+! a = x[2]
+! b = x[2]
+! c = x[3]
+! y[2] = z
+! d = x[2]
+! e = y[2]
+! f = x[3]
+!
+! After alias analysis:
+!
+! a = x[2]
+! b = a /* ELIMINATED */
+! c = x[3]
+! y[2] = z
+! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
+! e = z /* ELIMINATED */
+! f = c /* ELIMINATED */
+!
+! Simple pseudo-C example showing store elimination:
+!
+! Before alias analysis:
+!
+! x[0] = a
+! b = x[n]
+! x[0] = c
+! x[1] = d
+! e = x[0]
+! x[1] = c
+!
+! After alias analysis:
+!
+! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
+! b = x[n]
+! x[0] = c
+! /* x[1] = d */ /* ELIMINATED */
+! e = c
+! x[1] = c
+
+! Map vregs -> alias classes
+SYMBOL: vregs>acs
+
+: check [ "BUG: static type error detected" throw ] unless* ; inline
+
+: vreg>ac ( vreg -- ac )
+ #! Only vregs produced by %%allot, %peek and %%slot can
+ #! ever be used as valid inputs to %%slot and %%set-slot,
+ #! so we assert this fact by not giving alias classes to
+ #! other vregs.
+ vregs>acs get at check ;
+
+! Map alias classes -> sequence of vregs
+SYMBOL: acs>vregs
+
+: ac>vregs ( ac -- vregs ) acs>vregs get at ;
+
+: aliases ( vreg -- vregs )
+ #! All vregs which may contain the same value as vreg.
+ vreg>ac ac>vregs ;
+
+: each-alias ( vreg quot -- )
+ [ aliases ] dip each ; inline
+
+! Map vregs -> slot# -> vreg
+SYMBOL: live-slots
+
+! Current instruction number
+SYMBOL: insn#
+
+! Load/store history, for dead store elimination
+TUPLE: load insn# ;
+TUPLE: store insn# ;
+
+: new-action ( class -- action )
+ insn# get swap boa ; inline
+
+! Maps vreg -> slot# -> sequence of loads/stores
+SYMBOL: histories
+
+: history ( vreg -- history ) histories get at ;
+
+: set-ac ( vreg ac -- )
+ #! Set alias class of newly-seen vreg.
+ {
+ [ drop H{ } clone swap histories get set-at ]
+ [ drop H{ } clone swap live-slots get set-at ]
+ [ swap vregs>acs get set-at ]
+ [ acs>vregs get push-at ]
+ } 2cleave ;
+
+: live-slot ( slot#/f vreg -- vreg' )
+ #! If the slot number is unknown, we never reuse a previous
+ #! value.
+ over [ live-slots get at at ] [ 2drop f ] if ;
+
+: load-constant-slot ( value slot# vreg -- )
+ live-slots get at check set-at ;
+
+: load-slot ( value slot#/f vreg -- )
+ over [ load-constant-slot ] [ 3drop ] if ;
+
+: record-constant-slot ( slot# vreg -- )
+ #! A load can potentially read every store of this slot#
+ #! in that alias class.
+ [
+ history [ load new-action swap ?push ] change-at
+ ] with each-alias ;
+
+: record-computed-slot ( vreg -- )
+ #! Computed load is like a load of every slot touched so far
+ [
+ history values [ load new-action swap push ] each
+ ] each-alias ;
+
+: remember-slot ( value slot#/f vreg -- )
+ over
+ [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+ [ 2nip record-computed-slot ] if ;
+
+SYMBOL: ac-counter
+
+: next-ac ( -- n )
+ ac-counter [ dup 1+ ] change ;
+
+! Alias class for objects which are loaded from the data stack
+! or other object slots. We pessimistically assume that they
+! can all alias each other.
+SYMBOL: heap-ac
+
+: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
+
+: set-new-ac ( vreg -- ) next-ac set-ac ;
+
+: kill-constant-set-slot ( slot# vreg -- )
+ [ live-slots get at delete-at ] with each-alias ;
+
+: record-constant-set-slot ( slot# vreg -- )
+ history [
+ dup empty? [ dup peek store? [ dup pop* ] when ] unless
+ store new-action swap ?push
+ ] change-at ;
+
+: kill-computed-set-slot ( ac -- )
+ [ live-slots get at clear-assoc ] each-alias ;
+
+: remember-set-slot ( slot#/f vreg -- )
+ over [
+ [ record-constant-set-slot ]
+ [ kill-constant-set-slot ] 2bi
+ ] [ nip kill-computed-set-slot ] if ;
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+ dup copies get at swap or ;
+
+SYMBOL: constants
+
+: constant ( vreg -- n/f )
+ #! Return an %iconst value, or f if the vreg was not
+ #! assigned by an %iconst.
+ resolve constants get at ;
+
+! We treat slot accessors and stack traffic alike
+GENERIC: insn-slot# ( insn -- slot#/f )
+GENERIC: insn-object ( insn -- vreg )
+
+M: %peek insn-slot# n>> ;
+M: %replace insn-slot# n>> ;
+M: %%slot insn-slot# slot>> constant ;
+M: %%set-slot insn-slot# slot>> constant ;
+
+M: %peek insn-object stack>> ;
+M: %replace insn-object stack>> ;
+M: %%slot insn-object obj>> resolve ;
+M: %%set-slot insn-object obj>> resolve ;
+
+: init-alias-analysis ( -- )
+ H{ } clone histories set
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone constants set
+ H{ } clone copies set
+
+ 0 ac-counter set
+ next-ac heap-ac set
+
+ %data next-ac set-ac
+ %retain next-ac set-ac ;
+
+GENERIC: analyze-aliases ( insn -- insn' )
+
+M: %iconst analyze-aliases
+ dup [ value>> ] [ out>> ] bi constants get set-at ;
+
+M: %%allot analyze-aliases
+ #! A freshly allocated object is distinct from any other
+ #! object.
+ dup out>> set-new-ac ;
+
+M: read-op analyze-aliases
+ dup out>> set-heap-ac
+ dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
+ 2dup live-slot dup [
+ 2nip %copy boa analyze-aliases nip
+ ] [
+ drop remember-slot
+ ] if ;
+
+: idempotent? ( value slot#/f vreg -- ? )
+ #! Are we storing a value back to the same slot it was read
+ #! from?
+ live-slot = ;
+
+M: write-op analyze-aliases
+ dup
+ [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
+ 3dup idempotent? [
+ 2drop 2drop nop
+ ] [
+ [ remember-set-slot drop ] [ load-slot ] 3bi
+ ] if ;
+
+M: %copy analyze-aliases
+ #! The output vreg gets the same alias class as the input
+ #! vreg, since they both contain the same value.
+ dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
+
+M: vop analyze-aliases ;
+
+SYMBOL: live-stores
+
+: compute-live-stores ( -- )
+ histories get
+ values [
+ values [ [ store? ] filter [ insn#>> ] map ] map concat
+ ] map concat unique
+ live-stores set ;
+
+GENERIC: eliminate-dead-store ( insn -- insn' )
+
+: (eliminate-dead-store) ( insn -- insn' )
+ dup insn-slot# [
+ insn# get live-stores get key? [
+ drop nop
+ ] unless
+ ] when ;
+
+M: %replace eliminate-dead-store
+ #! Writes to above the top of the stack can be pruned also.
+ #! This is sound since any such writes are not observable
+ #! after the basic block, and any reads of those locations
+ #! will have been converted to copies by analyze-slot,
+ #! and the final stack height of the basic block is set at
+ #! the beginning by compiler.cfg.stack.
+ dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
+
+M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
+
+M: vop eliminate-dead-store ;
+
+: alias-analysis ( insns -- insns' )
+ init-alias-analysis
+ [ insn# set analyze-aliases ] map-index
+ compute-live-stores
+ [ insn# set eliminate-dead-store ] map-index ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel assocs sequences sequences.lib fry accessors
+compiler.cfg compiler.vops compiler.vops.builder
+namespaces math inference.dataflow optimizer.allot combinators
+math.order ;
+IN: compiler.cfg.builder
+
+! Convert dataflow IR to procedure CFG.
+! We construct the graph and set successors first, then we
+! set predecessors in a separate pass. This simplifies the
+! logic.
+
+SYMBOL: procedures
+
+SYMBOL: values>vregs
+
+SYMBOL: loop-nesting
+
+GENERIC: convert* ( node -- )
+
+GENERIC: convert ( node -- )
+
+: init-builder ( -- )
+ H{ } clone values>vregs set
+ V{ } clone loop-nesting set ;
+
+: end-basic-block ( -- )
+ basic-block get [ %b emit ] when ;
+
+: set-basic-block ( basic-block -- )
+ [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+ <basic-block> basic-block get
+ [
+ end-basic-block
+ dupd successors>> push
+ ] when*
+ set-basic-block ;
+
+: convert-nodes ( node -- )
+ dup basic-block get and [
+ [ convert ] [ successor>> convert-nodes ] bi
+ ] [ drop ] if ;
+
+: (build-cfg) ( node word -- )
+ init-builder
+ begin-basic-block
+ basic-block get swap procedures get set-at
+ %prolog emit
+ convert-nodes ;
+
+: build-cfg ( node word -- procedures )
+ H{ } clone [
+ procedures [ (build-cfg) ] with-variable
+ ] keep ;
+
+: value>vreg ( value -- vreg )
+ values>vregs get at ;
+
+: output-vreg ( value vreg -- )
+ swap values>vregs get set-at ;
+
+: produce-vreg ( value -- vreg )
+ next-vreg [ output-vreg ] keep ;
+
+: (load-inputs) ( seq stack -- )
+ over empty? [ 2drop ] [
+ [ <reversed> ] dip
+ [ '[ produce-vreg _ , %peek emit ] each-index ]
+ [ [ length neg ] dip %height emit ]
+ 2bi
+ ] if ;
+
+: load-inputs ( node -- )
+ [ in-d>> %data (load-inputs) ]
+ [ in-r>> %retain (load-inputs) ]
+ bi ;
+
+: (store-outputs) ( seq stack -- )
+ over empty? [ 2drop ] [
+ [ <reversed> ] dip
+ [ [ length ] dip %height emit ]
+ [ '[ value>vreg _ , %replace emit ] each-index ]
+ 2bi
+ ] if ;
+
+: store-outputs ( node -- )
+ [ out-d>> %data (store-outputs) ]
+ [ out-r>> %retain (store-outputs) ]
+ bi ;
+
+M: #push convert*
+ out-d>> [
+ [ produce-vreg ] [ value-literal ] bi
+ emit-literal
+ ] each ;
+
+M: #shuffle convert* drop ;
+
+M: #>r convert* drop ;
+
+M: #r> convert* drop ;
+
+M: node convert
+ [ load-inputs ]
+ [ convert* ]
+ [ store-outputs ]
+ tri ;
+
+: (emit-call) ( word -- )
+ begin-basic-block %call emit begin-basic-block ;
+
+: intrinsic-inputs ( node -- )
+ [ load-inputs ]
+ [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
+ bi ;
+
+: intrinsic-outputs ( node -- )
+ [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
+ [ store-outputs ]
+ bi ;
+
+: intrinsic ( node quot -- )
+ [
+ init-intrinsic
+
+ [ intrinsic-inputs ]
+ swap
+ [ intrinsic-outputs ]
+ tri
+ ] with-scope ; inline
+
+USING: kernel.private math.private slots.private
+optimizer.allot ;
+
+: maybe-emit-fixnum-shift-fast ( node -- node )
+ dup dup in-d>> second node-literal? [
+ dup dup in-d>> second node-literal
+ '[ , emit-fixnum-shift-fast ] intrinsic
+ ] [
+ dup param>> (emit-call)
+ ] if ;
+
+: emit-call ( node -- )
+ dup param>> {
+ { \ tag [ [ emit-tag ] intrinsic ] }
+
+ { \ slot [ [ dup emit-slot ] intrinsic ] }
+ { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
+
+ { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
+ { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
+ { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
+ { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
+ { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
+ { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
+ { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
+ { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
+ { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
+ { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
+ { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
+ { \ eq? [ [ emit-eq? ] intrinsic ] }
+
+ { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
+
+ { \ float+ [ [ emit-float+ ] intrinsic ] }
+ { \ float- [ [ emit-float- ] intrinsic ] }
+ { \ float* [ [ emit-float* ] intrinsic ] }
+ { \ float/f [ [ emit-float/f ] intrinsic ] }
+ { \ float<= [ [ emit-float<= ] intrinsic ] }
+ { \ float>= [ [ emit-float>= ] intrinsic ] }
+ { \ float< [ [ emit-float< ] intrinsic ] }
+ { \ float> [ [ emit-float> ] intrinsic ] }
+ { \ float? [ [ emit-float= ] intrinsic ] }
+
+ { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+ { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+ { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+
+ [ (emit-call) ]
+ } case drop ;
+
+M: #call convert emit-call ;
+
+M: #call-label convert
+ dup param>> loop-nesting get at [
+ basic-block get successors>> push
+ end-basic-block
+ basic-block off
+ drop
+ ] [
+ (emit-call)
+ ] if* ;
+
+: integer-conditional ( in1 in2 cc -- )
+ [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
+
+: float-conditional ( in1 in2 branch -- )
+ [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
+
+: emit-if ( #if -- )
+ in-d>> first value>vreg
+ next-vreg dup f emit-literal
+ cc/= integer-conditional ;
+
+: convert-nested ( node -- last-bb )
+ [
+ <basic-block>
+ [ set-basic-block ] keep
+ [ convert-nodes end-basic-block ] dip
+ basic-block get
+ ] with-scope
+ [ basic-block get successors>> push ] dip ;
+
+: convert-if-children ( #if -- )
+ children>> [ convert-nested ] map sift
+ <basic-block>
+ [ '[ , _ successors>> push ] each ]
+ [ set-basic-block ]
+ bi ;
+
+: phi-inputs ( #if -- vregs-seq )
+ children>>
+ [ last-node ] map
+ [ #values? ] filter
+ [ in-d>> [ value>vreg ] map ] map ;
+
+: phi-outputs ( #if -- vregs )
+ successor>> out-d>> [ produce-vreg ] map ;
+
+: emit-phi ( #if -- )
+ [ phi-outputs ] [ phi-inputs ] bi %phi emit ;
+
+M: #if convert
+ {
+ [ load-inputs ]
+ [ emit-if ]
+ [ convert-if-children ]
+ [ emit-phi ]
+ } cleave ;
+
+M: #values convert drop ;
+
+M: #merge convert drop ;
+
+M: #entry convert drop ;
+
+M: #declare convert drop ;
+
+M: #terminate convert drop ;
+
+M: #label convert
+ #! Labels create a new procedure.
+ [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
+
+M: #loop convert
+ #! Loops become part of the current CFG.
+ begin-basic-block
+ [ param>> basic-block get 2array loop-nesting get push ]
+ [ node-child convert-nodes ]
+ bi
+ loop-nesting get pop* ;
+
+M: #return convert
+ param>> loop-nesting get key? [
+ %epilog emit
+ %return emit
+ ] unless ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sequences sets fry ;
+IN: compiler.cfg
+
+! The id is a globally unique id used for fast hashcode* and
+! equal? on basic blocks. The number is assigned by
+! linearization.
+TUPLE: basic-block < identity-tuple
+id
+number
+instructions
+successors
+predecessors
+stack-frame ;
+
+SYMBOL: next-block-id
+
+: <basic-block> ( -- basic-block )
+ basic-block new
+ next-block-id counter >>id
+ V{ } clone >>instructions
+ V{ } clone >>successors
+ V{ } clone >>predecessors ;
+
+M: basic-block hashcode* id>> nip ;
+
+! Utilities
+SYMBOL: visited-blocks
+
+: visit-block ( basic-block quot -- )
+ over visited-blocks get 2dup key?
+ [ 2drop 2drop ] [ conjoin call ] if ; inline
+
+: (each-block) ( basic-block quot -- )
+ '[
+ ,
+ [ call ]
+ [ [ successors>> ] dip '[ , (each-block) ] each ]
+ 2bi
+ ] visit-block ; inline
+
+: each-block ( basic-block quot -- )
+ H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
+
+: copy-at ( from to assoc -- )
+ 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces math layouts sequences locals
+combinators compiler.vops compiler.vops.builder
+compiler.cfg.builder ;
+IN: compiler.cfg.elaboration
+
+! This pass must run before conversion to machine IR to ensure
+! correctness.
+
+GENERIC: elaborate* ( insn -- )
+
+: slot-shift ( -- n )
+ tag-bits get cell log2 - ;
+
+:: compute-slot-known-tag ( insn -- addr )
+ { $1 $2 $3 $4 $5 } temps
+ init-intrinsic
+ $1 slot-shift %iconst emit ! load shift offset
+ $2 insn slot>> $1 %shr emit ! shift slot by shift offset
+ $3 insn tag>> %iconst emit ! load tag number
+ $4 $2 $3 %isub emit
+ $5 insn obj>> $4 %iadd emit ! compute slot offset
+ $5
+ ;
+
+:: compute-slot-any-tag ( insn -- addr )
+ { $1 $2 $3 $4 } temps
+ init-intrinsic
+ $1 insn obj>> emit-untag ! untag object
+ $2 slot-shift %iconst emit ! load shift offset
+ $3 insn slot>> $2 %shr emit ! shift slot by shift offset
+ $4 $1 $3 %iadd emit ! compute slot offset
+ $4
+ ;
+
+: compute-slot ( insn -- addr )
+ dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
+
+M: %%slot elaborate*
+ [ out>> ] [ compute-slot ] bi %load emit ;
+
+M: %%set-slot elaborate*
+ [ in>> ] [ compute-slot ] bi %store emit ;
+
+M: object elaborate* , ;
+
+: elaboration ( insns -- insns )
+ [ [ elaborate* ] each ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel compiler.vops ;
+IN: compiler.cfg.kill-nops
+
+! Smallest compiler pass ever.
+
+: kill-nops ( instructions -- instructions' )
+ [ nop? not ] filter ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors math.order sequences
+compiler.vops ;
+IN: compiler.cfg.live-ranges
+
+TUPLE: live-range from to ;
+
+! Maps vregs to live ranges
+SYMBOL: live-ranges
+
+: def ( n vreg -- )
+ [ dup live-range boa ] dip live-ranges get set-at ;
+
+: use ( n vreg -- )
+ live-ranges get at [ max ] change-to drop ;
+
+GENERIC: compute-live-ranges* ( n insn -- )
+
+M: nullary-op compute-live-ranges*
+ 2drop ;
+
+M: flushable-op compute-live-ranges*
+ out>> def ;
+
+M: effect-op compute-live-ranges*
+ in>> use ;
+
+M: unary-op compute-live-ranges*
+ [ out>> def ] [ in>> use ] 2bi ;
+
+M: binary-op compute-live-ranges*
+ [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
+
+M: %store compute-live-ranges*
+ [ call-next-method ] [ addr>> use ] 2bi ;
+
+: compute-live-ranges ( insns -- )
+ H{ } clone live-ranges set
+ [ swap compute-live-ranges* ] each-index ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg kernel accessors sequences ;
+IN: compiler.cfg.predecessors
+
+! Pass to compute precedecessors.
+
+: compute-predecessors ( procedure -- )
+ [
+ dup successors>>
+ [ predecessors>> push ] with each
+ ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel
+compiler.cfg
+compiler.cfg.predecessors
+compiler.cfg.stack
+compiler.cfg.alias
+compiler.cfg.write-barrier
+compiler.cfg.elaboration
+compiler.cfg.vn
+compiler.cfg.vn.conditions
+compiler.cfg.kill-nops ;
+IN: compiler.cfg.simplifier
+
+: simplify ( insns -- insns' )
+ normalize-height
+ alias-analysis
+ elaboration
+ value-numbering
+ eliminate-write-barrier
+ kill-nops ;
+
+: simplify-cfg ( procedure -- procedure )
+ dup compute-predecessors
+ dup [ [ simplify ] change-instructions drop ] each-block ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.vops ;
+IN: compiler.cfg.stack
+
+! Combine multiple stack height changes into one, done at the
+! start of the basic block.
+!
+! Alias analysis and value numbering assume this optimization
+! has been performed.
+
+! Current data and retain stack height is stored in
+! %data, %retain variables.
+GENERIC: compute-heights ( insn -- )
+
+M: %height compute-heights
+ [ n>> ] [ stack>> ] bi [ + ] change ;
+
+M: object compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn )
+
+M: %height normalize-height*
+ [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
+
+: (normalize-height) ( insn -- insn )
+ dup stack>> get '[ , + ] change-n ; inline
+
+M: %peek normalize-height* (normalize-height) ;
+
+M: %replace normalize-height* (normalize-height) ;
+
+M: object normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+ 0 %data set
+ 0 %retain set
+ [ [ compute-heights ] each ]
+ [ [ [ normalize-height* ] map ] with-scope ] bi
+ %data get dup zero? [ drop ] [ %data %height boa prefix ] if
+ %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
--- /dev/null
+Low-level optimizer operating on control flow graph SSA IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.liveness
+compiler.cfg.vn ;
+IN: compiler.cfg.vn.conditions
+
+! The CFG generator produces naive code for the following code
+! sequence:
+!
+! fixnum< [ ... ] [ ... ] if
+!
+! The fixnum< comparison generates a boolean, which is then
+! tested against f.
+!
+! Using value numbering, we optimize the comparison of a boolean
+! against f where the boolean is the result of comparison.
+
+: expr-f? ( expr -- ? )
+ dup op>> %iconst eq?
+ [ value>> \ f tag-number = ] [ drop f ] if ;
+
+: comparison-with-f? ( insn -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ dup code>> cc/= eq? [
+ in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
+ ] [ drop f f ] if ;
+
+: of-boolean? ( expr -- expr/f ? )
+ #! The expr is a binary-op %icmp or %fcmp.
+ in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
+
+: original-comparison ( expr -- in/f code/f )
+ [ in>> vn>vreg ] [ code>> ] bi ;
+
+: eliminate-boolean ( insn -- in/f code/f )
+ comparison-with-f? [
+ of-boolean? [
+ original-comparison
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+M: cond-branch make-value-node
+ #! If the conditional branch is testing the result of an
+ #! earlier comparison against f, we only mark as live the
+ #! earlier comparison, so DCE will eliminate the boolean.
+ dup eliminate-boolean drop swap in>> or live-vreg ;
+
+M: cond-branch eliminate
+ dup eliminate-boolean dup
+ [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel compiler.vops compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.constant-fold
+
+GENERIC: constant-fold ( insn -- insn' )
+
+M: vop constant-fold ;
+
+: expr>insn ( out constant-expr -- constant-op )
+ [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
+
+M: pure-op constant-fold
+ dup out>>
+ dup vreg>vn vn>expr
+ dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces sorting
+compiler.vops compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: nullary-expr < expr ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: boolean-expr < unary-expr code ;
+TUPLE: constant-expr < expr value ;
+TUPLE: literal-expr < unary-expr object ;
+
+! op is always %peek
+TUPLE: peek-expr < expr loc ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+ input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+GENERIC: >expr ( insn -- expr )
+
+M: %literal-table >expr
+ class nullary-expr boa ;
+
+M: constant-op >expr
+ [ class ] [ value>> ] bi constant-expr boa ;
+
+M: %literal >expr
+ [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
+
+M: unary-op >expr
+ [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
+
+M: binary-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ binary-expr boa ;
+
+M: commutative-op >expr
+ [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
+ sort-pair commutative-expr boa ;
+
+M: boolean-op >expr
+ [ class ] [ in>> vreg>vn ] [ code>> ] tri
+ boolean-expr boa ;
+
+M: %peek >expr
+ [ class ] [ stack-loc ] bi peek-expr boa ;
+
+M: flushable-op >expr
+ class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+ 0 input-expr-counter set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs biassocs accessors
+math.order prettyprint.backend parser ;
+IN: compiler.cfg.vn.graph
+
+TUPLE: vn n ;
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
+
+: VN: scan-word vn boa parsed ; parsing
+
+M: vn <=> [ n>> ] compare ;
+
+M: vn pprint* \ VN: pprint-word n>> pprint* ;
+
+! biassoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
+
+: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+
+SYMBOL: vregs>vns
+
+: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+
+: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+
+: init-value-graph ( -- )
+ 0 vn-counter set
+ <bihash> exprs>vns set
+ <bihash> vregs>vns set ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs sets accessors compiler.vops
+compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.liveness
+
+! A set of VNs which are (transitively) used by effect-ops. This
+! is precisely the set of VNs whose value is needed outside of
+! the basic block.
+SYMBOL: live-vns
+
+GENERIC: live-expr ( expr -- )
+
+: live-vn ( vn -- )
+ #! Mark a VN and all VNs used in its computation as live.
+ dup live-vns get key? [ drop ] [
+ [ live-vns get conjoin ] [ vn>expr live-expr ] bi
+ ] if ;
+
+: live-vreg ( vreg -- ) vreg>vn live-vn ;
+
+M: expr live-expr drop ;
+M: literal-expr live-expr in>> live-vn ;
+M: unary-expr live-expr in>> live-vn ;
+M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
+
+: live? ( vreg -- ? )
+ dup vreg>vn tuck vn>vreg =
+ [ live-vns get key? ] [ drop f ] if ;
+
+: init-liveness ( -- )
+ H{ } clone live-vns set ;
+
+GENERIC: eliminate ( insn -- insn' )
+
+M: flushable-op eliminate dup out>> live? ?nop ;
+M: vop eliminate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.vops
+compiler.cfg.vn.graph ;
+IN: compiler.cfg.vn.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+
+GENERIC: propogate ( insn -- insn )
+
+M: effect-op propogate
+ [ resolve ] change-in ;
+
+M: unary-op propogate
+ [ resolve ] change-in ;
+
+M: binary-op propogate
+ [ resolve ] change-in1
+ [ resolve ] change-in2 ;
+
+M: %phi propogate
+ [ [ resolve ] map ] change-in ;
+
+M: %%slot propogate
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %%set-slot propogate
+ call-next-method
+ [ resolve ] change-obj
+ [ resolve ] change-slot ;
+
+M: %store propogate
+ call-next-method
+ [ resolve ] change-addr ;
+
+M: nullary-op propogate ;
+
+M: flushable-op propogate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math math.order
+layouts locals
+compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions ;
+IN: compiler.cfg.vn.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: constant ( val type -- expr ) swap constant-expr boa ;
+
+: simplify-not ( in -- vn/expr/f )
+ {
+ { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
+ { [ dup op>> %not = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-box-float ( in -- vn/expr/f )
+ {
+ { [ dup op>> %%unbox-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+: simplify-unbox-float ( in -- vn/expr/f )
+ {
+ { [ dup literal-expr? ] [ object>> %fconst constant ] }
+ { [ dup op>> %%box-float = ] [ in>> ] }
+ [ drop f ]
+ } cond ;
+
+M: unary-expr simplify*
+ #! Note the copy propagation: a %copy always simplifies to
+ #! its source vn.
+ [ in>> vn>expr ] [ op>> ] bi {
+ { %copy [ ] }
+ { %not [ simplify-not ] }
+ { %%box-float [ simplify-box-float ] }
+ { %%unbox-float [ simplify-unbox-float ] }
+ [ 2drop f ]
+ } case ;
+
+: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
+
+: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
+
+: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
+
+: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
+
+: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
+
+: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
+
+: identity ( in1 in2 val type -- expr ) constant 2nip ;
+
+: constant-fold? ( in1 in2 -- ? )
+ [ constant-expr? ] both? ;
+
+:: constant-fold ( in1 in2 quot type -- expr )
+ in1 in2 constant-fold?
+ [ in1 value>> in2 value>> quot call type constant ]
+ [ f ]
+ if ; inline
+
+: simplify-iadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over izero? ] [ nip ] }
+ { [ dup izero? ] [ drop ] }
+ [ [ + ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over ione? ] [ nip ] }
+ { [ dup ione? ] [ drop ] }
+ [ [ * ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-and ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ 0 %iconst identity ] }
+ { [ dup ineg-one? ] [ drop ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitand ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-or ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ dup ineg-one? ] [ -1 %iconst identity ] }
+ { [ 2dup = ] [ drop ] }
+ [ [ bitor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-xor ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ bitxor ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-fadd ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fzero? ] [ nip ] }
+ { [ dup fzero? ] [ drop ] }
+ [ [ + ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fmul ( in1 in2 -- vn/expr/f )
+ {
+ { [ over fone? ] [ nip ] }
+ { [ dup fone? ] [ drop ] }
+ [ [ * ] %fconst constant-fold ]
+ } cond ;
+
+: commutative-operands ( expr -- in1 in2 )
+ [ in1>> vn>expr ] [ in2>> vn>expr ] bi
+ over constant-expr? [ swap ] when ;
+
+M: commutative-expr simplify*
+ [ commutative-operands ] [ op>> ] bi {
+ { %iadd [ simplify-iadd ] }
+ { %imul [ simplify-imul ] }
+ { %and [ simplify-and ] }
+ { %or [ simplify-or ] }
+ { %xor [ simplify-xor ] }
+ { %fadd [ simplify-fadd ] }
+ { %fmul [ simplify-fmul ] }
+ [ 3drop f ]
+ } case ;
+
+: simplify-isub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ - ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-idiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ drop ] }
+ [ [ /i ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-imod ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup ione? ] [ 0 %iconst identity ] }
+ { [ 2dup = ] [ 0 %iconst identity ] }
+ [ [ mod ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-shl ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ [ [ shift ] %iconst constant-fold ]
+ } cond ;
+
+: unsigned ( n -- n' )
+ cell-bits 2^ 1- bitand ;
+
+: useless-shift? ( in1 in2 -- ? )
+ over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
+
+: simplify-shr ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift unsigned ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-sar ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ { [ over izero? ] [ drop ] }
+ { [ 2dup useless-shift? ] [ drop in1>> ] }
+ [ [ neg shift ] %iconst constant-fold ]
+ } cond ;
+
+: simplify-icmp ( in1 in2 -- vn/expr/f )
+ = [ +eq+ %cconst constant ] [ f ] if ;
+
+: simplify-fsub ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup izero? ] [ drop ] }
+ [ [ - ] %fconst constant-fold ]
+ } cond ;
+
+: simplify-fdiv ( in1 in2 -- vn/expr/f )
+ {
+ { [ dup fone? ] [ drop ] }
+ [ [ /i ] %fconst constant-fold ]
+ } cond ;
+
+M: binary-expr simplify*
+ [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
+ { %isub [ simplify-isub ] }
+ { %idiv [ simplify-idiv ] }
+ { %imod [ simplify-imod ] }
+ { %shl [ simplify-shl ] }
+ { %shr [ simplify-shr ] }
+ { %sar [ simplify-sar ] }
+ { %icmp [ simplify-icmp ] }
+ { %fsub [ simplify-fsub ] }
+ { %fdiv [ simplify-fdiv ] }
+ [ 3drop f ]
+ } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+ dup simplify* {
+ { [ dup not ] [ drop expr>vn ] }
+ { [ dup expr? ] [ expr>vn nip ] }
+ { [ dup vn? ] [ nip ] }
+ } cond ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences compiler.vops
+compiler.cfg.vn.graph
+compiler.cfg.vn.expressions
+compiler.cfg.vn.simplify
+compiler.cfg.vn.liveness
+compiler.cfg.vn.constant-fold
+compiler.cfg.vn.propagate ;
+IN: compiler.cfg.vn
+
+: insn>vn ( insn -- vn ) >expr simplify ; inline
+
+GENERIC: make-value-node ( insn -- )
+M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
+M: effect-op make-value-node in>> live-vreg ;
+M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
+M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
+M: nullary-op make-value-node drop ;
+
+: init-value-numbering ( -- )
+ init-value-graph
+ init-expressions
+ init-liveness ;
+
+: value-numbering ( instructions -- instructions )
+ init-value-numbering
+ [ [ make-value-node ] each ]
+ [ [ eliminate constant-fold propogate ] map ]
+ bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences
+compiler.vops compiler.cfg ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+SYMBOL: hits
+
+GENERIC: eliminate-write-barrier* ( insn -- insn' )
+
+M: %%allot eliminate-write-barrier*
+ dup out>> hits get conjoin ;
+
+M: %write-barrier eliminate-write-barrier*
+ dup in>> hits get key?
+ [ drop nop ] [ dup in>> hits get conjoin ] if ;
+
+M: %copy eliminate-write-barrier*
+ dup in/out hits get copy-at ;
+
+M: vop eliminate-write-barrier* ;
+
+: eliminate-write-barrier ( insns -- insns )
+ H{ } clone hits set
+ [ eliminate-write-barrier* ] map ;
--- /dev/null
+USING: help.markup help.syntax sequences quotations words
+compiler.tree stack-checker.errors ;
+IN: compiler.frontend
+
+ARTICLE: "specializers" "Word specializers"
+"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
+$nl
+"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
+$nl
+"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+$nl
+"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
+$nl
+"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
+$nl
+"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
+{ $code
+"\\ append"
+"{ { string string } { array array } }"
+"\"specializer\" set-word-prop"
+}
+"The specialized version of a word which will be compiled by the compiler can be inspected:"
+{ $subsection specialized-def } ;
+
+HELP: dataflow
+{ $values { "quot" quotation } { "dataflow" node } }
+{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
+{ $notes "This is the first stage of the compiler." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: dataflow-with
+{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
+{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: specialized-def
+{ $values { "word" word } { "quot" quotation } }
+{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
--- /dev/null
+
+
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
+USE: inference.dataflow
+
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
+
+{ 1 0 }
+[
+ [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] must-infer-as
+
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors quotations kernel sequences namespaces assocs
+words generic generic.standard generic.standard.engines arrays
+kernel.private combinators vectors stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree.builder ;
+IN: compiler.frontend
+
+: with-dataflow ( quot -- dataflow )
+ [ tree-builder new dataflow-visitor set ] prepose
+ with-infer first>> ; inline
+
+GENERIC# dataflow-with 1 ( quot stack -- dataflow )
+
+M: callable dataflow-with
+ #! Not safe to call from inference transforms.
+ [
+ >vector meta-d set
+ f infer-quot
+ ] with-dataflow nip ;
+
+: dataflow ( quot -- dataflow ) f dataflow-with ;
+
+: (make-specializer) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: make-specializer ( classes -- quot )
+ dup length <reversed>
+ [ (picker) 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ dup empty? [ drop [ t ] ] [
+ [ (make-specializer) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if ;
+
+: specializer-cases ( quot word -- default alist )
+ dup [ array? ] all? [ 1array ] unless [
+ [ make-specializer ] keep
+ '[ , declare ] pick append
+ ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+ dup "method-generic" word-prop dispatch# object <array>
+ swap "method-class" word-prop prefix ;
+
+: specialize-method ( quot method -- quot' )
+ method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+ specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+ dup method-body? [
+ "method-generic" word-prop standard-generic?
+ ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+ dup def>> swap {
+ { [ dup standard-method? ] [ specialize-method ] }
+ {
+ [ dup "specializer" word-prop ]
+ [ "specializer" word-prop specialize-quot ]
+ }
+ [ drop ]
+ } cond ;
+
+: word-dataflow ( word -- effect dataflow )
+ [
+ [
+ dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
+ dup "no-compile" word-prop [ cannot-infer-effect ] when
+ dup specialized-def over dup 2array 1array infer-quot
+ finish-word
+ ] maybe-cannot-infer
+ ] with-dataflow ;
+
+: specialized-length ( specializer -- n )
+ dup [ array? ] all? [ first ] when length ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.lvops
+
+! Machine representation ("linear virtual operations"). Uses
+! same operations as CFG basic blocks, except edges and branches
+! are replaced by linear jumps (_b* instances).
+
+TUPLE: _label label ;
+
+! Unconditional jump to label
+TUPLE: _b label ;
+
+! Integer
+TUPLE: _bi label in code ;
+TUPLE: _bf label in code ;
+
+! Dispatch table, jumps to one of following _address
+! depending value of 'in'
+TUPLE: _dispatch in ;
+TUPLE: _address word ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces
+compiler.cfg compiler.vops compiler.lvops ;
+IN: compiler.machine.builder
+
+SYMBOL: block-counter
+
+: number-basic-block ( basic-block -- )
+ #! Make this fancy later.
+ dup number>> [ drop ] [
+ block-counter [ dup 1+ ] change >>number
+ [ , ] [
+ successors>> <reversed>
+ [ number-basic-block ] each
+ ] bi
+ ] if ;
+
+: flatten-basic-blocks ( procedure -- blocks )
+ [
+ 0 block-counter
+ [ number-basic-block ]
+ with-variable
+ ] { } make ;
+
+GENERIC: linearize-instruction ( basic-block insn -- )
+
+M: object linearize-instruction
+ , drop ;
+
+M: %b linearize-instruction
+ drop successors>> first number>> _b emit ;
+
+: conditional-branch ( basic-block insn class -- )
+ [ successors>> ] 2dip
+ [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
+ [ 2drop second number>> _b emit ]
+ 3bi ; inline
+
+M: %bi linearize-instruction _bi conditional-branch ;
+M: %bf linearize-instruction _bf conditional-branch ;
+
+: build-mr ( procedure -- insns )
+ [
+ flatten-basic-blocks [
+ [ number>> _label emit ]
+ [ dup instructions>> [ linearize-instruction ] with each ]
+ bi
+ ] each
+ ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences assocs io
+prettyprint inference generator optimizer compiler.vops
+compiler.cfg.builder compiler.cfg.simplifier
+compiler.machine.builder compiler.machine.simplifier ;
+IN: compiler.machine.debug
+
+: dataflow>linear ( dataflow word -- linear )
+ [
+ init-counter
+ build-cfg
+ [ simplify-cfg build-mr simplify-mr ] assoc-map
+ ] with-scope ;
+
+: linear. ( linear -- )
+ [
+ "==== " write swap .
+ [ . ] each
+ ] assoc-each ;
+
+: linearized-quot. ( quot -- )
+ dataflow optimize
+ "Anonymous quotation" dataflow>linear
+ linear. ;
+
+: linearized-word. ( word -- )
+ dup word-dataflow nip optimize swap dataflow>linear linear. ;
+
+: >basic-block ( quot -- basic-block )
+ dataflow optimize
+ [
+ init-counter
+ "Anonymous quotation" build-cfg
+ >alist first second simplify-cfg
+ ] with-scope ;
+
+: basic-block. ( basic-block -- )
+ instructions>> [ . ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences.next compiler.lvops ;
+IN: compiler.machine.simplifier
+
+: useless-branch? ( next insn -- ? )
+ 2dup [ _label? ] [ _b? ] bi* and
+ [ [ label>> ] bi@ = ] [ 2drop f ] if ;
+
+: simplify-mr ( insns -- insns )
+ #! Remove unconditional branches to labels immediately
+ #! following.
+ [
+ [
+ tuck useless-branch?
+ [ drop ] [ , ] if
+ ] each-next
+ ] { } make ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel sequences compiler.tree
+stack-checker.visitor ;
+IN: compiler.tree.builder
+
+TUPLE: tree-builder first last ;
+
+: node, ( node -- )
+ dataflow-visitor get swap
+ over last>>
+ [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
+ [ [ >>first ] [ >>last ] bi drop ]
+ if ;
+
+M: tree-builder child-visitor tree-builder new ;
+M: tree-builder #introduce, #introduce node, ;
+M: tree-builder #call, #call node, ;
+M: tree-builder #call-recursive, #call-recursive node, ;
+M: tree-builder #push, #push node, ;
+M: tree-builder #shuffle, #shuffle node, ;
+M: tree-builder #drop, #drop node, ;
+M: tree-builder #>r, #>r node, ;
+M: tree-builder #r>, #r> node, ;
+M: tree-builder #return, #return node, ;
+M: tree-builder #terminate, #terminate node, ;
+M: tree-builder #if, [ first>> ] bi@ #if node, ;
+M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
+M: tree-builder #phi, #phi node, ;
+M: tree-builder #declare, #declare node, ;
+M: tree-builder #recursive, first>> #recursive node, ;
+M: tree-builder #copy, #copy node, ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry arrays generic assocs kernel math namespaces parser
+sequences words vectors math.intervals effects classes
+accessors combinators compiler.tree ;
+IN: compiler.tree.combinators
+
+: node-exists? ( node quot -- ? )
+ over [
+ 2dup 2slip rot [
+ 2drop t
+ ] [
+ [ [ children>> ] [ successor>> ] bi suffix ] dip
+ '[ , node-exists? ] contains?
+ ] if
+ ] [
+ 2drop f
+ ] if ; inline
+
+SYMBOL: node-stack
+
+: >node ( node -- ) node-stack get push ;
+: node> ( -- node ) node-stack get pop ;
+: node@ ( -- node ) node-stack get peek ;
+
+: iterate-next ( -- node ) node@ successor>> ;
+
+: iterate-nodes ( node quot -- )
+ over [
+ [ swap >node call node> drop ] keep iterate-nodes
+ ] [
+ 2drop
+ ] if ; inline
+
+: (each-node) ( quot -- next )
+ node@ [ swap call ] 2keep
+ node-children [
+ [
+ [ (each-node) ] keep swap
+ ] iterate-nodes
+ ] each drop
+ iterate-next ; inline
+
+: with-node-iterator ( quot -- )
+ >r V{ } clone node-stack r> with-variable ; inline
+
+: each-node ( node quot -- )
+ [
+ swap [
+ [ (each-node) ] keep swap
+ ] iterate-nodes drop
+ ] with-node-iterator ; inline
+
+: map-children ( node quot -- )
+ over [
+ over children>> [
+ '[ , map ] change-children drop
+ ] [
+ 2drop
+ ] if
+ ] [
+ 2drop
+ ] if ; inline
+
+: (transform-nodes) ( prev node quot -- )
+ dup >r call dup [
+ >>successor
+ successor>> dup successor>>
+ r> (transform-nodes)
+ ] [
+ r> 2drop f >>successor drop
+ ] if ; inline
+
+: transform-nodes ( node quot -- new-node )
+ over [
+ [ call dup dup successor>> ] keep (transform-nodes)
+ ] [ drop ] if ; inline
+
+: tail-call? ( -- ? )
+ #! We don't consider calls which do non-local exits to be
+ #! tail calls, because this gives better error traces.
+ node-stack get [
+ successor>> [ #tail? ] [ #terminate? not ] bi and
+ ] all? ;
--- /dev/null
+USING: namespaces assocs sequences compiler.frontend
+compiler.tree.dead-code compiler.tree.def-use compiler.tree
+compiler.tree.combinators tools.test kernel math
+stack-checker.state accessors ;
+IN: compiler.tree.dead-code.tests
+
+\ remove-dead-code must-infer
+
+: count-live-values ( quot -- n )
+ dataflow
+ compute-def-use
+ remove-dead-code
+ compute-def-use
+ 0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
+
+[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 drop ] count-live-values ] unit-test
+
+[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
+
+[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+
+[ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
+
+[ 3 ] [ [ 1 2 + 3 + ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
+
+[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ ] call ] count-live-values ] unit-test
+
+[ 1 ] [ [ [ 1 ] call ] count-live-values ] unit-test
+
+[ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs dequeues search-dequeues
+kernel sequences words sets stack-checker.inlining compiler.tree
+compiler.tree.combinators compiler.tree.def-use ;
+IN: compiler.tree.dead-code
+
+! Dead code elimination: remove #push and flushable #call whose
+! outputs are unused.
+
+SYMBOL: live-values
+SYMBOL: work-list
+
+: live-value? ( value -- ? )
+ live-values get at ;
+
+: look-at-value ( values -- )
+ work-list get push-front ;
+
+: look-at-values ( values -- )
+ work-list get '[ , push-front ] each ;
+
+GENERIC: mark-live-values ( node -- )
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+M: #introduce mark-live-values look-at-outputs ;
+
+M: #if mark-live-values look-at-inputs ;
+
+M: #dispatch mark-live-values look-at-inputs ;
+
+M: #call mark-live-values
+ dup word>> "flushable" word-prop [ drop ] [
+ [ look-at-inputs ]
+ [ look-at-outputs ]
+ bi
+ ] if ;
+
+M: #return mark-live-values
+ #! Values returned by local #recursive functions can be
+ #! killed if they're unused.
+ dup label>>
+ [ drop ] [ look-at-inputs ] if ;
+
+M: node mark-live-values drop ;
+
+GENERIC: propagate* ( value node -- )
+
+M: #copy propagate*
+ #! If the output of a copy is live, then the corresponding
+ #! input is live also.
+ [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call propagate*
+ #! If any of the outputs of a call are live, then all
+ #! inputs and outputs must be live.
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive propagate*
+ #! If the output of a copy is live, then the corresponding
+ #! inputs to #return nodes are live also.
+ [ out-d>> <reversed> index ] keep label>> returns>>
+ [ <reversed> nth look-at-value ] with each ;
+
+M: #>r propagate* nip in-d>> first look-at-value ;
+
+M: #r> propagate* nip in-r>> first look-at-value ;
+
+M: #shuffle propagate* mapping>> at look-at-value ;
+
+: look-at-corresponding ( value inputs outputs -- )
+ [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+M: #phi propagate*
+ #! If any of the outputs of a #phi are live, then the
+ #! corresponding inputs are live too.
+ [ [ out-d>> ] [ phi-in-d>> flip ] bi look-at-corresponding ]
+ [ [ out-r>> ] [ phi-in-r>> flip ] bi look-at-corresponding ]
+ 2bi ;
+
+M: node propagate* 2drop ;
+
+: propogate-liveness ( value -- )
+ live-values get 2dup key? [
+ 2drop
+ ] [
+ dupd conjoin
+ dup defined-by propagate*
+ ] if ;
+
+: compute-live-values ( node -- )
+ #! We add f initially because #phi nodes can have f in their
+ #! inputs.
+ <hashed-dlist> work-list set
+ H{ { f f } } clone live-values set
+ [ mark-live-values ] each-node
+ work-list get [ propogate-liveness ] slurp-dequeue ;
+
+GENERIC: remove-dead-values* ( node -- )
+
+M: #>r remove-dead-values*
+ dup out-r>> first live-value? [ { } >>out-r ] unless
+ dup in-d>> first live-value? [ { } >>in-d ] unless
+ drop ;
+
+M: #r> remove-dead-values*
+ dup out-d>> first live-value? [ { } >>out-d ] unless
+ dup in-r>> first live-value? [ { } >>in-r ] unless
+ drop ;
+
+M: #push remove-dead-values*
+ dup out-d>> first live-value? [ { } >>out-d ] unless
+ drop ;
+
+: filter-corresponding-values ( in out -- in' out' )
+ zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
+
+: remove-dead-copies ( node -- )
+ dup
+ [ in-d>> ] [ out-d>> ] bi
+ filter-corresponding-values
+ [ >>in-d ] [ >>out-d ] bi*
+ drop ;
+
+: filter-live ( values -- values' )
+ [ live-value? ] filter ;
+
+M: #shuffle remove-dead-values*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-out-d
+ drop ;
+
+M: #declare remove-dead-values* remove-dead-copies ;
+
+M: #copy remove-dead-values* remove-dead-copies ;
+
+: remove-dead-phi-d ( #phi -- #phi )
+ dup
+ [ phi-in-d>> flip ] [ out-d>> ] bi
+ filter-corresponding-values
+ [ flip >>phi-in-d ] [ >>out-d ] bi* ;
+
+: remove-dead-phi-r ( #phi -- #phi )
+ dup
+ [ phi-in-r>> flip ] [ out-r>> ] bi
+ filter-corresponding-values
+ [ flip >>phi-in-r ] [ >>out-r ] bi* ;
+
+M: #phi remove-dead-values*
+ remove-dead-phi-d
+ remove-dead-phi-r
+ drop ;
+
+M: node remove-dead-values* drop ;
+
+GENERIC: remove-dead-nodes* ( node -- newnode/t )
+
+: live-call? ( #call -- ? )
+ out-d>> [ live-value? ] contains? ;
+
+M: #call remove-dead-nodes*
+ dup live-call? [ drop t ] [
+ [ in-d>> #drop ] [ successor>> ] bi >>successor
+ ] if ;
+
+: prune-if ( node quot -- successor/t )
+ over >r call [ r> successor>> ] [ r> drop t ] if ;
+ inline
+
+M: #shuffle remove-dead-nodes*
+ [ in-d>> empty? ] prune-if ;
+
+M: #push remove-dead-nodes*
+ [ out-d>> empty? ] prune-if ;
+
+M: #>r remove-dead-nodes*
+ [ in-d>> empty? ] prune-if ;
+
+M: #r> remove-dead-nodes*
+ [ in-r>> empty? ] prune-if ;
+
+M: node remove-dead-nodes* drop t ;
+
+: (remove-dead-code) ( node -- newnode )
+ dup [
+ dup remove-dead-values*
+ dup remove-dead-nodes* dup t eq? [
+ drop dup [ (remove-dead-code) ] map-children
+ ] [
+ nip (remove-dead-code)
+ ] if
+ ] when ;
+
+: remove-dead-code ( node -- newnode )
+ [
+ [ compute-live-values ]
+ [ [ (remove-dead-code) ] transform-nodes ] bi
+ ] with-scope ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: accessors namespaces assocs kernel sequences math
+tools.test words sets combinators.short-circuit
+stack-checker.state compiler.tree compiler.frontend
+compiler.tree.def-use arrays kernel.private ;
+IN: compiler.tree.def-use.tests
+
+\ compute-def-use must-infer
+
+[ t ] [
+ [ 1 2 3 ] dataflow compute-def-use drop
+ def-use get {
+ [ assoc-size 3 = ]
+ [ values [ uses>> [ #return? ] all? ] all? ]
+ } 1&&
+] unit-test
+
+! compute-def-use checks for SSA violations, so we make sure
+! some common patterns are generated correctly.
+{
+ [ [ drop ] each-integer ]
+ [ [ 2drop ] curry each-integer ]
+ [ [ 1 ] [ 2 ] if drop ]
+ [ [ 1 ] [ dup ] if ]
+ [ [ 1 ] [ dup ] if drop ]
+ [ { array } declare swap ]
+ [ [ ] curry call ]
+ [ [ 1 ] [ 2 ] compose call + ]
+ [ [ 1 ] 2 [ + ] curry compose call + ]
+ [ [ 1 ] [ call 2 ] curry call + ]
+ [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
+} [
+ [ ] swap [ dataflow compute-def-use drop ] curry unit-test
+] each
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel generic assocs classes
+vectors accessors combinators sets stack-checker.state
+compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.def-use
+
+SYMBOL: def-use
+
+TUPLE: definition value node uses ;
+
+: <definition> ( value -- definition )
+ definition new
+ swap >>value
+ V{ } clone >>uses ;
+
+: def-of ( value -- definition )
+ def-use get [ <definition> ] cache ;
+
+: def-value ( node value -- )
+ def-of [ [ "Multiple defs" throw ] when ] change-node drop ;
+
+: used-by ( value -- nodes ) def-of uses>> ;
+
+: use-value ( node value -- ) used-by push ;
+
+: defined-by ( value -- node ) def-use get at node>> ;
+
+GENERIC: node-uses-values ( node -- values )
+
+M: #phi node-uses-values
+ [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append ;
+
+M: #r> node-uses-values in-r>> ;
+
+M: node node-uses-values in-d>> ;
+
+GENERIC: node-defs-values ( node -- values )
+
+M: #introduce node-defs-values values>> ;
+
+M: #>r node-defs-values out-r>> ;
+
+M: node node-defs-values out-d>> ;
+
+: each-value ( node values quot -- )
+ [ sift ] dip with each ; inline
+
+: node-def-use ( node -- )
+ [ dup node-uses-values [ use-value ] each-value ]
+ [ dup node-defs-values [ def-value ] each-value ] bi ;
+
+: check-def-use ( -- )
+ def-use get [
+ nip
+ [ node>> [ "No def" throw ] unless ]
+ [ uses>> all-unique? [ "Uses not all unique" throw ] unless ]
+ bi
+ ] assoc-each ;
+
+: compute-def-use ( node -- node )
+ H{ } clone def-use set
+ dup [ node-def-use ] each-node
+ check-def-use ;
--- /dev/null
+Def/use chain construction
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry kernel sequences assocs accessors namespaces
+math.intervals arrays classes.algebra
+compiler.tree
+compiler.tree.propagation.simple
+compiler.tree.propagation.constraints ;
+IN: compiler.tree.propagation.branches
+
+! For conditionals, an assoc of child node # --> constraint
+GENERIC: child-constraints ( node -- seq )
+
+M: #if child-constraints
+ [
+ \ f class-not 0 `input class,
+ f 0 `input literal,
+ ] make-constraints ;
+
+M: #dispatch child-constraints
+ dup [
+ children>> length [ 0 `input literal, ] each
+ ] make-constraints ;
+
+DEFER: (propagate)
+
+: infer-children ( node -- assocs )
+ [ children>> ] [ child-constraints ] bi [
+ [
+ value-classes [ clone ] change
+ value-literals [ clone ] change
+ value-intervals [ clone ] change
+ constraints [ clone ] change
+ apply-constraint
+ (propagate)
+ ] H{ } make-assoc
+ ] 2map ;
+
+: merge-classes ( inputs outputs results -- )
+ '[
+ , null
+ [ [ value-class ] bind class-or ] 2reduce
+ _ set-value-class
+ ] 2each ;
+
+: merge-intervals ( inputs outputs results -- )
+ '[
+ , [ [ value-interval ] bind ] 2map
+ dup first [ interval-union ] reduce
+ _ set-value-interval
+ ] 2each ;
+
+: merge-literals ( inputs outputs results -- )
+ '[
+ , [ [ value-literal 2array ] bind ] 2map
+ dup all-eq? [ first first2 ] [ drop f f ] if
+ _ swap [ set-value-literal ] [ 2drop ] if
+ ] 2each ;
+
+: merge-stuff ( inputs outputs results -- )
+ [ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
+
+: merge-children ( results node -- )
+ successor>> dup #phi? [
+ [ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
+ [ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
+ 2bi
+ ] [ 2drop ] if ;
+
+M: #branch propagate-around
+ [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs math math.intervals kernel accessors
+sequences namespaces disjoint-sets classes classes.algebra
+combinators words compiler.tree ;
+IN: compiler.tree.propagation.constraints
+
+! A constraint is a statement about a value.
+
+! We need a notion of equality which doesn't recurse so cannot
+! infinite loop on circular data
+GENERIC: eql? ( obj1 obj2 -- ? )
+M: object eql? eq? ;
+M: number eql? number= ;
+
+! Maps constraints to constraints
+SYMBOL: constraints
+
+TUPLE: literal-constraint literal value ;
+
+C: <literal-constraint> literal-constraint
+
+M: literal-constraint equal?
+ over literal-constraint? [
+ [ [ literal>> ] bi@ eql? ]
+ [ [ value>> ] bi@ = ]
+ 2bi and
+ ] [ 2drop f ] if ;
+
+TUPLE: class-constraint class value ;
+
+C: <class-constraint> class-constraint
+
+TUPLE: interval-constraint interval value ;
+
+C: <interval-constraint> interval-constraint
+
+GENERIC: apply-constraint ( constraint -- )
+GENERIC: constraint-satisfied? ( constraint -- ? )
+
+: `input ( n -- value ) node get in-d>> nth ;
+: `output ( n -- value ) node get out-d>> nth ;
+: class, ( class value -- ) <class-constraint> , ;
+: literal, ( literal value -- ) <literal-constraint> , ;
+: interval, ( interval value -- ) <interval-constraint> , ;
+
+M: f apply-constraint drop ;
+
+: make-constraints ( node quot -- constraint )
+ [ swap node set call ] { } make ; inline
+
+: set-constraints ( node quot -- )
+ make-constraints
+ unclip [ 2array ] reduce
+ apply-constraint ; inline
+
+: assume ( constraint -- )
+ constraints get at [ apply-constraint ] when* ;
+
+! Disjoint set of copy equivalence
+SYMBOL: copies
+
+: is-copy-of ( val copy -- ) copies get equate ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: resolve-copy ( copy -- val ) copies get representative ;
+
+: introduce-value ( val -- ) copies get add-atom ;
+
+! Current value --> literal mapping
+SYMBOL: value-literals
+
+! Current value --> interval mapping
+SYMBOL: value-intervals
+
+! Current value --> class mapping
+SYMBOL: value-classes
+
+: value-interval ( value -- interval/f )
+ resolve-copy value-intervals get at ;
+
+: set-value-interval ( interval value -- )
+ resolve-copy value-intervals get set-at ;
+
+: intersect-value-interval ( interval value -- )
+ resolve-copy value-intervals get [ interval-intersect ] change-at ;
+
+M: interval-constraint apply-constraint
+ [ interval>> ] [ value>> ] bi intersect-value-interval ;
+
+: set-class-interval ( class value -- )
+ over class? [
+ [ "interval" word-prop ] dip over
+ [ resolve-copy set-value-interval ] [ 2drop ] if
+ ] [ 2drop ] if ;
+
+: value-class ( value -- class )
+ resolve-copy value-classes get at null or ;
+
+: set-value-class ( class value -- )
+ resolve-copy over [
+ dup value-intervals get at [
+ 2dup set-class-interval
+ ] unless
+ 2dup <class-constraint> assume
+ ] when
+ value-classes get set-at ;
+
+: intersect-value-class ( class value -- )
+ resolve-copy value-classes get [ class-and ] change-at ;
+
+M: class-constraint apply-constraint
+ [ class>> ] [ value>> ] bi intersect-value-class ;
+
+: literal-interval ( value -- interval/f )
+ dup real? [ [a,a] ] [ drop f ] if ;
+
+: value-literal ( value -- obj ? )
+ resolve-copy value-literals get at* ;
+
+: set-value-literal ( literal value -- )
+ resolve-copy {
+ [ [ class ] dip set-value-class ]
+ [ [ literal-interval ] dip set-value-interval ]
+ [ <literal-constraint> assume ]
+ [ value-literals get set-at ]
+ } 2cleave ;
+
+M: literal-constraint apply-constraint
+ [ literal>> ] [ value>> ] bi set-value-literal ;
+
+M: literal-constraint constraint-satisfied?
+ dup value>> value-literal
+ [ swap literal>> eql? ] [ 2drop f ] if ;
+
+M: class-constraint constraint-satisfied?
+ [ value>> value-class ] [ class>> ] bi class<= ;
+
+M: pair apply-constraint
+ first2
+ [ constraints get set-at ]
+ [ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
+
+M: pair constraint-satisfied?
+ first constraint-satisfied? ;
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences namespaces hashtables
+compiler.tree
+compiler.tree.def-use
+compiler.tree.propagation.constraints
+compiler.tree.propagation.simple
+compiler.tree.propagation.branches
+compiler.tree.propagation.recursive ;
+IN: compiler.tree.propagation
+
+: (propagate) ( node -- )
+ [
+ [ node-defs-values [ introduce-value ] each ]
+ [ propagate-around ]
+ [ successor>> ]
+ tri
+ (propagate)
+ ] when* ;
+
+: propagate-with ( node classes literals intervals -- )
+ [
+ H{ } clone constraints set
+ >hashtable value-intervals set
+ >hashtable value-literals set
+ >hashtable value-classes set
+ (propagate)
+ ] with-scope ;
+
+: propagate ( node -- node )
+ dup f f f propagate-with ;
+
+: propagate/node ( node existing -- )
+ #! Infer classes, using the existing node's class info as a
+ #! starting point.
+ [ classes>> ] [ literals>> ] [ intervals>> ] tri
+ propagate-with ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.tree compiler.tree.propagation.simple
+compiler.tree.propagation.branches ;
+IN: compiler.tree.propagation.recursive
+
+! M: #recursive child-constraints
+! drop { f } ;
+!
+! M: #recursive propagate-around
+! [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
+!
+! : classes= ( inferred current -- ? )
+! 2dup min-length '[ , tail* ] bi@ sequence= ;
+!
+! SYMBOL: fixed-point?
+!
+! SYMBOL: nested-labels
+!
+! : annotate-entry ( nodes #label -- )
+! [ (merge-classes) ] dip node-child
+! 2dup node-output-classes classes=
+! [ 2drop ] [ set-classes fixed-point? off ] if ;
+!
+! : init-recursive-calls ( #label -- )
+! #! We set recursive calls to output the empty type, then
+! #! repeat inference until a fixed point is reached.
+! #! Hopefully, our type functions are monotonic so this
+! #! will always converge.
+! returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
+!
+! M: #label propagate-before ( #label -- )
+! [ init-recursive-calls ]
+! [ [ 1array ] keep annotate-entry ] bi ;
+!
+! : infer-label-loop ( #label -- )
+! fixed-point? on
+! dup node-child (propagate)
+! dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
+! fixed-point? get [ drop ] [ infer-label-loop ] if ;
+!
+! M: #label propagate-around ( #label -- )
+! #! Now merge the types at every recursion point with the
+! #! entry types.
+! [
+! {
+! [ nested-labels get push ]
+! [ annotate-node ]
+! [ propagate-before ]
+! [ infer-label-loop ]
+! [ drop nested-labels get pop* ]
+! } cleave
+! ] with-scope ;
+!
+! : find-label ( param -- #label )
+! word>> nested-labels get [ word>> eq? ] with find nip ;
+!
+! M: #call-recursive propagate-before ( #call-label -- )
+! [ label>> returns>> (merge-classes) ] [ out-d>> ] bi
+! [ set-value-class ] 2each ;
+!
+! M: #return propagate-around
+! nested-labels get length 0 > [
+! dup word>> nested-labels get peek word>> eq? [
+! [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
+! classes= not [
+! fixed-point? off
+! [ in-d>> value-classes get valid-keys ] keep
+! set-node-classes
+! ] [ drop ] if
+! ] [ call-next-method ] if
+! ] [ call-next-method ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors kernel sequences assocs words namespaces
+combinators classes.algebra compiler.tree
+compiler.tree.propagation.constraints ;
+IN: compiler.tree.propagation.simple
+
+GENERIC: propagate-before ( node -- )
+
+M: #introduce propagate-before
+ values>> [ object swap set-value-class ] each ;
+
+M: #push propagate-before
+ [ literal>> ] [ out-d>> first ] bi set-value-literal ;
+
+M: #declare propagate-before
+ [ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
+ [ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
+ bi ;
+
+M: #shuffle propagate-before
+ [ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
+
+M: #>r propagate-before
+ [ in-d>> ] [ out-r>> ] bi are-copies-of ;
+
+M: #r> propagate-before
+ [ in-r>> ] [ out-d>> ] bi are-copies-of ;
+
+M: #copy propagate-before
+ [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+
+: intersect-classes ( classes values -- )
+ [ intersect-value-class ] 2each ;
+
+: intersect-intervals ( intervals values -- )
+ [ intersect-value-interval ] 2each ;
+
+: predicate-constraints ( class #call -- )
+ [
+ ! If word outputs true, input is an instance of class
+ [
+ 0 `input class,
+ \ f class-not 0 `output class,
+ ] set-constraints
+ ] [
+ ! If word outputs false, input is not an instance of class
+ [
+ class-not 0 `input class,
+ \ f 0 `output class,
+ ] set-constraints
+ ] 2bi ;
+
+: compute-constraints ( #call -- )
+ dup word>> "constraints" word-prop [
+ call
+ ] [
+ dup word>> "predicating" word-prop dup
+ [ swap predicate-constraints ] [ 2drop ] if
+ ] if* ;
+
+: compute-output-classes ( node word -- classes intervals )
+ dup word>> "output-classes" word-prop
+ dup [ call ] [ 2drop f f ] if ;
+
+: output-classes ( node -- classes intervals )
+ dup compute-output-classes [
+ [ ] [ word>> "default-output-classes" word-prop ] ?if
+ ] dip ;
+
+: intersect-values ( classes intervals values -- )
+ tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+
+M: #call propagate-before
+ [ compute-constraints ]
+ [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+
+M: node propagate-before drop ;
+
+GENERIC: propagate-after ( node -- )
+
+: input-classes ( #call -- classes )
+ word>> "input-classes" word-prop ;
+
+M: #call propagate-after
+ [ input-classes ] [ in-d>> ] bi intersect-classes ;
+
+M: node propagate-after drop ;
+
+GENERIC: propagate-around ( node -- )
+
+: valid-keys ( seq assoc -- newassoc )
+ '[ dup resolve-copy , at ] H{ } map>assoc
+ [ nip ] assoc-filter
+ f assoc-like ;
+
+: annotate-node ( node -- )
+ #! Annotate the node with the currently-inferred set of
+ #! value classes.
+ dup node-values {
+ [ value-intervals get valid-keys >>intervals ]
+ [ value-classes get valid-keys >>classes ]
+ [ value-literals get valid-keys >>literals ]
+ [ 2drop ]
+ } cleave ;
+
+M: object propagate-around
+ {
+ [ propagate-before ]
+ [ annotate-node ]
+ [ propagate-after ]
+ } cleave ;
--- /dev/null
+Class, interval, constant propagation
--- /dev/null
+High-level optimizer operating on lexical tree SSA IR
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs kernel math namespaces parser
+sequences words vectors math.intervals effects classes
+accessors combinators stack-checker.state ;
+IN: compiler.tree
+
+! High-level tree SSA form.
+!
+! Invariants:
+! 1) Each value has exactly one definition. A "definition" means
+! the value appears in the out-d or out-r slot of a node, or the
+! values slot of an #introduce node.
+! 2) Each value appears only once in the inputs of a node, where
+! the inputs are the concatenation of in-d and in-r, or in the
+! case of a #phi node, the sequence of sequences in the phi-in-r
+! and phi-in-d slots.
+! 3) A value is never used in the same node where it is defined.
+
+TUPLE: node < identity-tuple
+in-d out-d in-r out-r
+classes literals intervals
+history successor children ;
+
+M: node hashcode* drop node hashcode* ;
+
+: node-shuffle ( node -- shuffle )
+ [ in-d>> ] [ out-d>> ] bi <effect> ;
+
+: node-values ( node -- values )
+ { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
+ 4array concat ;
+
+: node-child ( node -- child ) node-children first ;
+
+: last-node ( node -- last )
+ dup successor>> [ last-node ] [ ] ?if ;
+
+: penultimate-node ( node -- penultimate )
+ dup successor>> dup [
+ dup successor>>
+ [ nip penultimate-node ] [ drop ] if
+ ] [
+ 2drop f
+ ] if ;
+
+: node-literal? ( node value -- ? )
+ swap literals>> key? ;
+
+: node-literal ( node value -- obj )
+ swap literals>> at ;
+
+: node-interval ( node value -- interval )
+ swap intervals>> at ;
+
+: node-class ( node value -- class )
+ swap classes>> at ;
+
+: node-input-classes ( node -- seq )
+ dup in-d>> [ node-class ] with map ;
+
+: node-output-classes ( node -- seq )
+ dup out-d>> [ node-class ] with map ;
+
+: node-input-intervals ( node -- seq )
+ dup in-d>> [ node-interval ] with map ;
+
+: node-class-first ( node -- class )
+ dup in-d>> first node-class ;
+
+TUPLE: #introduce < node values ;
+
+: #introduce ( values -- node )
+ \ #introduce new swap >>values ;
+
+TUPLE: #call < node word ;
+
+: #call ( inputs outputs word -- node )
+ \ #call new
+ swap >>word
+ swap >>out-d
+ swap >>in-d ;
+
+TUPLE: #call-recursive < node label ;
+
+: #call-recursive ( inputs outputs label -- node )
+ \ #call-recursive new
+ swap >>label
+ swap >>out-d
+ swap >>in-d ;
+
+TUPLE: #push < node literal ;
+
+: #push ( literal value -- node )
+ \ #push new
+ swap 1array >>out-d
+ swap >>literal ;
+
+TUPLE: #shuffle < node mapping ;
+
+: #shuffle ( inputs outputs mapping -- node )
+ \ #shuffle new
+ swap >>mapping
+ swap >>out-d
+ swap >>in-d ;
+
+: #drop ( inputs -- node )
+ { } { } #shuffle ;
+
+TUPLE: #>r < node ;
+
+: #>r ( inputs outputs -- node )
+ \ #>r new
+ swap >>out-r
+ swap >>in-d ;
+
+TUPLE: #r> < node ;
+
+: #r> ( inputs outputs -- node )
+ \ #r> new
+ swap >>out-d
+ swap >>in-r ;
+
+TUPLE: #terminate < node ;
+
+: #terminate ( -- node ) \ #terminate new ;
+
+TUPLE: #branch < node ;
+
+: new-branch ( value children class -- node )
+ new
+ swap >>children
+ swap 1array >>in-d ; inline
+
+TUPLE: #if < #branch ;
+
+: #if ( ? true false -- node )
+ 2array \ #if new-branch ;
+
+TUPLE: #dispatch < #branch ;
+
+: #dispatch ( n branches -- node )
+ \ #dispatch new-branch ;
+
+TUPLE: #phi < node phi-in-d phi-in-r ;
+
+: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
+ \ #phi new
+ swap >>out-r
+ swap >>phi-in-r
+ swap >>out-d
+ swap >>phi-in-d ;
+
+TUPLE: #declare < node declaration ;
+
+: #declare ( inputs outputs declaration -- node )
+ \ #declare new
+ swap >>declaration
+ swap >>out-d
+ swap >>in-d ;
+
+TUPLE: #return < node label ;
+
+: #return ( label stack -- node )
+ \ #return new
+ swap >>in-d
+ swap >>label ;
+
+TUPLE: #recursive < node word label loop? returns calls ;
+
+: #recursive ( word label inputs outputs child -- node )
+ \ #recursive new
+ swap 1array >>children
+ swap >>out-d
+ swap >>in-d
+ swap >>label
+ swap >>word ;
+
+TUPLE: #copy < node ;
+
+: #copy ( inputs outputs -- node )
+ \ #copy new
+ swap >>out-d
+ swap >>in-d ;
+
+DEFER: #tail?
+
+PREDICATE: #tail-phi < #phi successor>> #tail? ;
+
+UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel namespaces words layouts sequences classes
+classes.algebra accessors math arrays byte-arrays
+inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
+IN: compiler.vops.builder
+
+<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
+
+! Temps Inputs Outputs
+TEMP: $1 TEMP: #1 TEMP: ^1
+TEMP: $2 TEMP: #2 TEMP: ^2
+TEMP: $3 TEMP: #3 TEMP: ^3
+TEMP: $4 TEMP: #4 TEMP: ^4
+TEMP: $5 TEMP: #5 TEMP: ^5
+
+GENERIC: emit-literal ( vreg object -- )
+
+M: fixnum emit-literal ( vreg object -- )
+ tag-bits get shift %iconst emit ;
+
+M: f emit-literal
+ class tag-number %iconst emit ;
+
+M: object emit-literal ( vreg object -- )
+ next-vreg [ %literal-table emit ] keep
+ swap %literal emit ;
+
+: temps ( seq -- ) [ next-vreg swap set ] each ;
+
+: init-intrinsic ( -- )
+ { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
+
+: load-iconst ( value -- vreg )
+ [ next-vreg dup ] dip %iconst emit ;
+
+: load-tag-mask ( -- vreg )
+ tag-mask get load-iconst ;
+
+: load-tag-bits ( -- vreg )
+ tag-bits get load-iconst ;
+
+: emit-tag-fixnum ( out in -- )
+ load-tag-bits %shl emit ;
+
+: emit-untag-fixnum ( out in -- )
+ load-tag-bits %sar emit ;
+
+: emit-untag ( out in -- )
+ next-vreg dup tag-mask get bitnot %iconst emit
+ %and emit ;
+
+: emit-tag ( -- )
+ $1 #1 load-tag-mask %and emit
+ ^1 $1 emit-tag-fixnum ;
+
+: emit-slot ( node -- )
+ [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: emit-write-barrier ( node -- )
+ dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
+
+: emit-set-slot ( node -- )
+ [ emit-write-barrier ]
+ [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
+ bi ;
+
+: emit-fixnum-bitnot ( -- )
+ $1 #1 %not emit
+ ^1 $1 load-tag-mask %xor emit ;
+
+: emit-fixnum+fast ( -- )
+ ^1 #1 #2 %iadd emit ;
+
+: emit-fixnum-fast ( -- )
+ ^1 #1 #2 %isub emit ;
+
+: emit-fixnum-bitand ( -- )
+ ^1 #1 #2 %and emit ;
+
+: emit-fixnum-bitor ( -- )
+ ^1 #1 #2 %or emit ;
+
+: emit-fixnum-bitxor ( -- )
+ ^1 #1 #2 %xor emit ;
+
+: emit-fixnum*fast ( -- )
+ $1 #1 emit-untag-fixnum
+ ^1 $1 #2 %imul emit ;
+
+: emit-fixnum-shift-left-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ ^1 #1 $1 %shl emit ;
+
+: emit-fixnum-shift-right-fast ( n -- )
+ [ $1 ] dip %iconst emit
+ $2 #1 $1 %sar emit
+ ^1 $2 emit-untag ;
+
+: emit-fixnum-shift-fast ( n -- )
+ dup 0 >=
+ [ emit-fixnum-shift-left-fast ]
+ [ neg emit-fixnum-shift-right-fast ] if ;
+
+: emit-fixnum-compare ( cc -- )
+ $1 #1 #2 %icmp emit
+ [ ^1 $1 ] dip %%iboolean emit ;
+
+: emit-fixnum<= ( -- )
+ cc<= emit-fixnum-compare ;
+
+: emit-fixnum>= ( -- )
+ cc>= emit-fixnum-compare ;
+
+: emit-fixnum< ( -- )
+ cc< emit-fixnum-compare ;
+
+: emit-fixnum> ( -- )
+ cc> emit-fixnum-compare ;
+
+: emit-eq? ( -- )
+ cc= emit-fixnum-compare ;
+
+: emit-unbox-float ( out in -- )
+ %%unbox-float emit ;
+
+: emit-box-float ( out in -- )
+ %%box-float emit ;
+
+: emit-unbox-floats ( -- )
+ $1 #1 emit-unbox-float
+ $2 #2 emit-unbox-float ;
+
+: emit-float+ ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fadd emit
+ ^1 $3 emit-box-float ;
+
+: emit-float- ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fsub emit
+ ^1 $3 emit-box-float ;
+
+: emit-float* ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fmul emit
+ ^1 $3 emit-box-float ;
+
+: emit-float/f ( -- )
+ emit-unbox-floats
+ $3 $1 $2 %fdiv emit
+ ^1 $3 emit-box-float ;
+
+: emit-float-compare ( cc -- )
+ emit-unbox-floats
+ $3 $1 $2 %fcmp emit
+ [ ^1 $3 ] dip %%fboolean emit ;
+
+: emit-float<= ( -- )
+ cc<= emit-float-compare ;
+
+: emit-float>= ( -- )
+ cc>= emit-float-compare ;
+
+: emit-float< ( -- )
+ cc< emit-float-compare ;
+
+: emit-float> ( -- )
+ cc> emit-float-compare ;
+
+: emit-float= ( -- )
+ cc= emit-float-compare ;
+
+: emit-allot ( vreg size class -- )
+ [ tag-number ] [ type-number ] bi %%allot emit ;
+
+: emit-(tuple) ( layout -- )
+ [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 tuple tag-number %%set-slot emit ;
+
+: emit-(array) ( n -- )
+ [ [ ^1 ] dip 2 + array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 array tag-number %%set-slot emit ;
+
+: emit-(byte-array) ( n -- )
+ [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
+ [ [ $1 ] dip emit-literal ] bi
+ $2 1 emit-literal
+ $1 ^1 $2 byte-array tag-number %%set-slot emit ;
+
+! fixnum>bignum
+! bignum>fixnum
+! fixnum+
+! fixnum-
+! getenv, setenv
+! alien accessors
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser prettyprint.backend kernel accessors math
+math.order sequences namespaces arrays assocs ;
+IN: compiler.vops
+
+TUPLE: vreg n ;
+
+: VREG: scan-word vreg boa parsed ; parsing
+
+M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
+
+SYMBOL: vreg-counter
+
+: init-counter ( -- )
+ { 0 } clone vreg-counter set ;
+
+: next-vreg ( -- n )
+ 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
+
+: emit ( ... class -- ) boa , ; inline
+
+! ! ! Instructions. Those prefixed with %% are high level
+! ! ! instructions eliminated during the elaboration phase.
+TUPLE: vop ;
+
+! Instruction which does not touch vregs.
+TUPLE: nullary-op < vop ;
+
+! Does nothing
+TUPLE: nop < nullary-op ;
+
+: nop ( -- vop ) T{ nop } ;
+
+: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
+
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: flushable-op < vop out ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: pure-op < flushable-op ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: effect-op < vop in ;
+
+TUPLE: binary-op < pure-op in1 in2 ;
+
+: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
+
+: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
+
+TUPLE: unary-op < pure-op in ;
+
+! Merge point; out is a sequence of vregs in a sequence of
+! sequences of vregs
+TUPLE: %phi < pure-op in ;
+
+! Integer, floating point, condition register copy
+TUPLE: %copy < unary-op ;
+
+! Constants
+TUPLE: constant-op < pure-op value ;
+
+TUPLE: %iconst < constant-op ; ! Integer
+TUPLE: %fconst < constant-op ; ! Float
+TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
+
+! Load address of literal table into out
+TUPLE: %literal-table < pure-op ;
+
+! Load object literal from table.
+TUPLE: %literal < unary-op object ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: read-op < flushable-op ;
+TUPLE: write-op < effect-op ;
+
+! Stack shuffling
+SINGLETON: %data
+SINGLETON: %retain
+
+TUPLE: %peek < read-op n stack ;
+TUPLE: %replace < write-op n stack ;
+TUPLE: %height < nullary-op n stack ;
+
+: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
+
+TUPLE: commutative-op < binary-op ;
+
+! Integer arithmetic
+TUPLE: %iadd < commutative-op ;
+TUPLE: %isub < binary-op ;
+TUPLE: %imul < commutative-op ;
+TUPLE: %idiv < binary-op ;
+TUPLE: %imod < binary-op ;
+TUPLE: %icmp < binary-op ;
+
+! Bitwise ops
+TUPLE: %not < unary-op ;
+TUPLE: %and < commutative-op ;
+TUPLE: %or < commutative-op ;
+TUPLE: %xor < commutative-op ;
+TUPLE: %shl < binary-op ;
+TUPLE: %shr < binary-op ;
+TUPLE: %sar < binary-op ;
+
+! Float arithmetic
+TUPLE: %fadd < commutative-op ;
+TUPLE: %fsub < binary-op ;
+TUPLE: %fmul < commutative-op ;
+TUPLE: %fdiv < binary-op ;
+TUPLE: %fcmp < binary-op ;
+
+! Float/integer conversion
+TUPLE: %f>i < unary-op ;
+TUPLE: %i>f < unary-op ;
+
+! Float boxing/unboxing
+TUPLE: %%box-float < unary-op ;
+TUPLE: %%unbox-float < unary-op ;
+
+! High level slot accessors for alias analysis
+! tag is f; if its not f, we can generate a faster sequence
+TUPLE: %%slot < read-op obj slot tag ;
+TUPLE: %%set-slot < write-op obj slot tag ;
+
+TUPLE: %write-barrier < effect-op ;
+
+! Memory
+TUPLE: %load < unary-op ;
+TUPLE: %store < effect-op addr ;
+
+! Control flow; they jump to either the first or second successor
+! of the BB
+
+! Unconditional transfer to first successor
+TUPLE: %b < nullary-op ;
+
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
+
+: evaluate-cc ( result cc -- ? )
+ H{
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc/= { +lt+ +gt+ } }
+ } at memq? ;
+
+TUPLE: cond-branch < effect-op code ;
+
+TUPLE: %bi < cond-branch ;
+TUPLE: %bf < cond-branch ;
+
+! Convert condition register to a boolean
+TUPLE: boolean-op < unary-op code ;
+
+TUPLE: %%iboolean < boolean-op ;
+TUPLE: %%fboolean < boolean-op ;
+
+! Dispatch table, jumps to successor 0..n-1 depending value of
+! in, which must be in the range [0,n)
+TUPLE: %dispatch < effect-op ;
+
+! Procedures
+TUPLE: %return < nullary-op ;
+TUPLE: %prolog < nullary-op ;
+TUPLE: %epilog < nullary-op ;
+TUPLE: %jump < nullary-op word ;
+TUPLE: %call < nullary-op word ;
+
+! Heap allocation
+TUPLE: %%allot < flushable-op size tag type ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry arrays generic io io.streams.string kernel math
+namespaces parser prettyprint sequences strings vectors words
+quotations effects classes continuations debugger assocs
+combinators compiler.errors accessors math.order definitions
+sets generic.standard.engines.tuple stack-checker.state
+stack-checker.visitor stack-checker.errors ;
+IN: stack-checker.backend
+
+! Word properties we use
+SYMBOL: +inferred-effect+
+SYMBOL: +cannot-infer+
+SYMBOL: +infer+
+
+SYMBOL: visited
+
+: reset-on-redefine { +inferred-effect+ +cannot-infer+ } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ visited get conjoin ]
+ [
+ crossref get at keys
+ [ word? ] filter
+ [
+ [ reset-on-redefine [ word-prop ] with contains? ]
+ [ inline? ]
+ bi or
+ ] filter
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+! M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
+
+: push-d ( obj -- ) meta-d get push ;
+
+: pop-d ( -- obj )
+ meta-d get dup empty? [
+ drop <value> dup 1array #introduce, d-in inc
+ ] [ pop ] if ;
+
+: peek-d ( -- obj ) pop-d dup push-d ;
+
+: consume-d ( n -- seq ) [ pop-d ] replicate reverse ;
+
+: output-d ( values -- ) meta-d get push-all ;
+
+: ensure-d ( n -- values ) consume-d dup output-d ;
+
+: produce-d ( n -- values )
+ [ <value> ] replicate dup meta-d get push-all ;
+
+: push-r ( obj -- ) meta-r get push ;
+
+: pop-r ( -- obj )
+ meta-r get dup empty?
+ [ too-many-r> inference-error ] [ pop ] if ;
+
+: consume-r ( n -- seq ) [ pop-r ] replicate reverse ;
+
+: output-r ( seq -- ) meta-r get push-all ;
+
+: pop-literal ( -- rstate obj )
+ pop-d [ 1array #drop, ] [ literal [ recursion>> ] [ value>> ] bi ] bi ;
+
+GENERIC: apply-object ( obj -- )
+
+: push-literal ( obj -- )
+ <literal> dup make-known [ nip push-d ] [ #push, ] 2bi ;
+
+M: wrapper apply-object
+ wrapped>>
+ [ dup word? [ +called+ depends-on ] [ drop ] if ]
+ [ push-literal ]
+ bi ;
+
+M: object apply-object push-literal ;
+
+: terminate ( -- )
+ terminated? on #terminate, ;
+
+: infer-quot ( quot rstate -- )
+ recursive-state get [
+ recursive-state set
+ [ apply-object terminated? get not ] all? drop
+ ] dip recursive-state set ;
+
+: infer-quot-recursive ( quot word label -- )
+ 2array recursive-state get swap prefix infer-quot ;
+
+: time-bomb ( error -- )
+ '[ , throw ] recursive-state get infer-quot ;
+
+: bad-call ( -- )
+ "call must be given a callable" time-bomb ;
+
+: infer-literal-quot ( literal -- )
+ dup recursive-quotation? [
+ value>> recursive-quotation-error inference-error
+ ] [
+ dup value>> callable? [
+ [ value>> ]
+ [ [ recursion>> ] keep f 2array prefix ]
+ bi infer-quot
+ ] [
+ drop bad-call
+ ] if
+ ] if ;
+
+: infer->r ( n -- )
+ consume-d [ dup copy-values #>r, ] [ output-r ] bi ;
+
+: infer-r> ( n -- )
+ consume-r [ dup copy-values #r>, ] [ output-d ] bi ;
+
+: undo-infer ( -- )
+ recorded get [ f +inferred-effect+ set-word-prop ] each ;
+
+: consume/produce ( effect quot -- )
+ #! quot is ( inputs outputs -- )
+ [
+ [
+ [ in>> length consume-d ]
+ [ out>> length produce-d ]
+ bi
+ ] dip call
+ ] [
+ drop
+ terminated?>> [ terminate ] when
+ ] 2bi ; inline
+
+: check->r ( -- )
+ meta-r get empty? terminated? get or
+ [ \ too-many->r inference-error ] unless ;
+
+: end-infer ( -- )
+ check->r
+ f meta-d get clone #return, ;
+
+: effect-required? ( word -- ? )
+ {
+ { [ dup inline? ] [ drop f ] }
+ { [ dup deferred? ] [ drop f ] }
+ { [ dup crossref? not ] [ drop f ] }
+ [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ } cond ;
+
+: ?missing-effect ( word -- )
+ dup effect-required?
+ [ missing-effect inference-error ] [ drop ] if ;
+
+: check-effect ( word effect -- )
+ over stack-effect {
+ { [ dup not ] [ 2drop ?missing-effect ] }
+ { [ 2dup effect<= ] [ 3drop ] }
+ [ effect-error ]
+ } cond ;
+
+: finish-word ( word -- )
+ current-effect
+ [ check-effect ]
+ [ drop recorded get push ]
+ [ +inferred-effect+ set-word-prop ]
+ 2tri ;
+
+: maybe-cannot-infer ( word quot -- )
+ [ ] [ t +cannot-infer+ set-word-prop ] cleanup ; inline
+
+: infer-word ( word -- effect )
+ [
+ [
+ init-inference
+ init-known-values
+ dataflow-visitor off
+ dependencies off
+ [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
+ [ finish-word current-effect ]
+ bi
+ ] with-scope
+ ] maybe-cannot-infer ;
+
+: apply-word/effect ( word effect -- )
+ swap '[ , #call, ] consume/produce ;
+
+: required-stack-effect ( word -- effect )
+ dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
+
+: call-recursive-word ( word -- )
+ dup required-stack-effect apply-word/effect ;
+
+: custom-infer ( word -- )
+ [ +inlined+ depends-on ] [ +infer+ word-prop call ] bi ;
+
+: cached-infer ( word -- )
+ dup +inferred-effect+ word-prop apply-word/effect ;
+
+: non-inline-word ( word -- )
+ dup +called+ depends-on
+ {
+ { [ dup recursive-label ] [ call-recursive-word ] }
+ { [ dup +infer+ word-prop ] [ custom-infer ] }
+ { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+ { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
+ [ dup infer-word apply-word/effect ]
+ } cond ;
+
+: with-infer ( quot -- effect visitor )
+ [
+ [
+ V{ } clone recorded set
+ init-inference
+ init-known-values
+ dataflow-visitor off
+ call
+ end-infer
+ current-effect
+ dataflow-visitor get
+ ] [ ] [ undo-infer ] cleanup
+ ] with-scope ;
--- /dev/null
+Stack effect inference implementation
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry vectors sequences assocs math accessors kernel
+combinators quotations namespaces stack-checker.state
+stack-checker.backend stack-checker.errors stack-checker.visitor
+;
+IN: stack-checker.branches
+
+: balanced? ( seq -- ? )
+ [ first2 length - ] map all-equal? ;
+
+: phi-inputs ( seq -- newseq )
+ dup empty? [
+ dup [ length ] map supremum
+ '[ , f pad-left ] map
+ ] unless ;
+
+: unify-values ( values -- phi-out )
+ dup [ known ] map dup all-eq?
+ [ nip first make-known ] [ 2drop <value> ] if ;
+
+: phi-outputs ( phi-in -- stack )
+ flip [ unify-values ] map ;
+
+SYMBOL: quotations
+
+: unify-branches ( ins stacks -- in phi-in phi-out )
+ zip [ second ] filter dup empty? [ drop 0 { } { } ] [
+ dup balanced?
+ [ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
+ [ quotations get unbalanced-branches-error ]
+ if
+ ] if ;
+
+: branch-variable ( seq symbol -- seq )
+ '[ , _ at ] map ;
+
+: active-variable ( seq symbol -- seq )
+ [ [ terminated? over at [ drop f ] when ] map ] dip
+ branch-variable ;
+
+: datastack-phi ( seq -- phi-in phi-out )
+ [ d-in branch-variable ] [ meta-d active-variable ] bi
+ unify-branches
+ [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
+
+: retainstack-phi ( seq -- phi-in phi-out )
+ [ length 0 <repetition> ] [ meta-r active-variable ] bi
+ unify-branches
+ [ drop ] [ ] [ dup meta-r set ] tri* ;
+
+: compute-phi-function ( seq -- )
+ [ quotation active-variable sift quotations set ]
+ [ [ datastack-phi ] [ retainstack-phi ] bi #phi, ]
+ [ [ terminated? swap at ] all? terminated? set ]
+ tri ;
+
+: infer-branch ( literal -- namespace )
+ [
+ copy-inference
+ nest-visitor
+ [ value>> quotation set ] [ infer-literal-quot ] bi
+ ] H{ } make-assoc ; inline
+
+: infer-branches ( branches -- input children data )
+ [ pop-d ] dip
+ [ infer-branch ] map
+ [ dataflow-visitor branch-variable ] keep ;
+
+: infer-if ( branches -- )
+ infer-branches [ first2 #if, ] dip compute-phi-function ;
+
+: infer-dispatch ( branches -- )
+ infer-branches [ #dispatch, ] dip compute-phi-function ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax kernel effects sequences
+sequences.private words ;
+IN: stack-checker.errors
+
+HELP: literal-expected
+{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
+{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
+
+HELP: too-many->r
+{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
+{ $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
+
+HELP: too-many-r>
+{ $error-description "Thrown if inference notices a quotation popping elements from the return stack it did not place there." }
+{ $notes "See " { $link "shuffle-words" } " for retain stack usage conventions." } ;
+
+HELP: cannot-infer-effect
+{ $values { "word" word } }
+{ $description "Throws a " { $link cannot-infer-effect } " error." }
+{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
+
+HELP: effect-error
+{ $values { "word" word } { "effect" "an instance of " { $link effect } } }
+{ $description "Throws an " { $link effect-error } "." }
+{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
+
+HELP: missing-effect
+{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
+
+HELP: recursive-quotation-error
+{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
+{ $examples
+ "Here is an example of quotation recursion:"
+ { $code "[ [ dup call ] dup call ] infer." }
+} ;
+
+HELP: unbalanced-branches-error
+{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
+{ $description "Throws an " { $link unbalanced-branches-error } "." }
+{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." }
+{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile."
+$nl
+"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } ;
+
+ARTICLE: "inference-errors" "Inference errors"
+"Main wrapper for all inference errors:"
+{ $subsection inference-error }
+"Specific inference errors:"
+{ $subsection cannot-infer-effect }
+{ $subsection literal-expected }
+{ $subsection too-many->r }
+{ $subsection too-many-r> }
+{ $subsection recursive-quotation-error }
+{ $subsection unbalanced-branches-error }
+{ $subsection effect-error }
+{ $subsection missing-effect } ;
+
+ABOUT: "inference-errors"
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic sequences prettyprint io words arrays
+summary effects debugger assocs accessors namespaces
+compiler.errors ;
+IN: stack-checker.errors
+
+SYMBOL: recursive-state
+
+TUPLE: inference-error error type rstate ;
+
+M: inference-error compiler-error-type type>> ;
+
+M: inference-error error-help error>> error-help ;
+
+: (inference-error) ( ... class type -- * )
+ >r boa r>
+ recursive-state get
+ \ inference-error boa throw ; inline
+
+: inference-error ( ... class -- * )
+ +error+ (inference-error) ; inline
+
+: inference-warning ( ... class -- * )
+ +warning+ (inference-error) ; inline
+
+M: inference-error error.
+ [
+ rstate>> dup empty?
+ [ drop ] [ "Nesting:" print stack. ] if
+ ] [ error>> error. ] bi ;
+
+TUPLE: literal-expected ;
+
+M: literal-expected summary
+ drop "Literal value expected" ;
+
+TUPLE: unbalanced-branches-error branches quots ;
+
+: unbalanced-branches-error ( branches quots -- * )
+ \ unbalanced-branches-error inference-error ;
+
+M: unbalanced-branches-error error.
+ "Unbalanced branches:" print
+ [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
+ [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
+
+TUPLE: too-many->r ;
+
+M: too-many->r summary
+ drop
+ "Quotation pushes elements on retain stack without popping them" ;
+
+TUPLE: too-many-r> ;
+
+M: too-many-r> summary
+ drop
+ "Quotation pops retain stack elements which it did not push" ;
+
+TUPLE: cannot-infer-effect word ;
+
+: cannot-infer-effect ( word -- * )
+ \ cannot-infer-effect inference-warning ;
+
+M: cannot-infer-effect error.
+ "Unable to infer stack effect of " write word>> . ;
+
+TUPLE: missing-effect word ;
+
+M: missing-effect error.
+ "The word " write
+ word>> pprint
+ " must declare a stack effect" print ;
+
+TUPLE: effect-error word inferred declared ;
+
+: effect-error ( word inferred declared -- * )
+ \ effect-error inference-error ;
+
+M: effect-error error.
+ "Stack effects of the word " write
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> effect>string . ]
+ [ "Declared: " write declared>> effect>string . ] tri ;
+
+TUPLE: recursive-quotation-error quot ;
+
+M: recursive-quotation-error error.
+ "The quotation " write
+ quot>> pprint
+ " calls itself." print
+ "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
+
+TUPLE: undeclared-recursion-error word ;
+
+M: undeclared-recursion-error error.
+ "The inline recursive word " write
+ word>> pprint
+ " must be declared recursive" print ;
+
+TUPLE: diverging-recursion-error word ;
+
+M: diverging-recursion-error error.
+ "The recursive word " write
+ word>> pprint
+ " digs arbitrarily deep into the stack" print ;
+
+TUPLE: unbalanced-recursion-error word height ;
+
+M: unbalanced-recursion-error error.
+ "The recursive word " write
+ word>> pprint
+ " leaves with the stack having the wrong height" print ;
+
+TUPLE: inconsistent-recursive-call-error word ;
+
+M: inconsistent-recursive-call-error error.
+ "The recursive word " write
+ word>> pprint
+ " calls itself with a different set of quotation parameters than were input" print ;
--- /dev/null
+Errors which may be reaised by stack effect inference
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry namespaces assocs kernel sequences words accessors
+definitions math effects classes arrays combinators vectors
+stack-checker.state
+stack-checker.visitor
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors ;
+IN: stack-checker.inlining
+
+! Code to handle inline words. Much of the complexity stems from
+! having to handle recursive inline words.
+
+: (inline-word) ( word label -- )
+ [ [ def>> ] keep ] dip infer-quot-recursive ;
+
+TUPLE: inline-recursive word phi-in phi-out returns ;
+
+: <inline-recursive> ( word -- label )
+ inline-recursive new
+ swap >>word
+ V{ } clone >>returns ;
+
+: quotation-param? ( obj -- ? )
+ dup pair? [ second effect? ] [ drop f ] if ;
+
+: make-copies ( values effect-in -- values' )
+ [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
+
+SYMBOL: phi-in
+SYMBOL: phi-out
+
+: prepare-stack ( word -- )
+ required-stack-effect in>> [ length ensure-d ] keep
+ [ drop 1vector phi-in set ]
+ [ make-copies phi-out set ]
+ 2bi ;
+
+: emit-phi-function ( label -- )
+ phi-in get >>phi-in
+ phi-out get >>phi-out drop
+ phi-in get phi-out get { { } } { } #phi,
+ phi-out get >vector meta-d set ;
+
+: entry-stack-height ( label -- stack )
+ phi-out>> length ;
+
+: check-return ( word label -- )
+ 2dup
+ [ stack-effect effect-height ]
+ [ entry-stack-height current-stack-height swap - ]
+ bi*
+ = [ 2drop ] [
+ word>> current-stack-height
+ unbalanced-recursion-error inference-error
+ ] if ;
+
+: end-recursive-word ( word label -- )
+ [ check-return ]
+ [ meta-d get [ #return, ] [ swap returns>> push ] 2bi ]
+ bi ;
+
+: recursive-word-inputs ( label -- n )
+ entry-stack-height d-in get + ;
+
+: (inline-recursive-word) ( word -- word label in out visitor )
+ dup prepare-stack
+ [
+ init-inference
+ nest-visitor
+
+ dup <inline-recursive>
+ [ dup emit-phi-function (inline-word) ]
+ [ end-recursive-word ]
+ [ ]
+ 2tri
+
+ check->r
+
+ dup recursive-word-inputs
+ meta-d get
+ dataflow-visitor get
+ ] with-scope ;
+
+: inline-recursive-word ( word -- )
+ (inline-recursive-word)
+ [ consume-d ] [ dup output-d ] [ ] tri* #recursive, ;
+
+: check-call-height ( word label -- )
+ entry-stack-height current-stack-height >
+ [ diverging-recursion-error inference-error ] [ drop ] if ;
+
+: call-site-stack ( label -- stack )
+ required-stack-effect in>> length meta-d get swap tail* ;
+
+: check-call-site-stack ( stack label -- )
+ tuck phi-out>>
+ [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
+ [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
+
+: add-call ( word label -- )
+ [ check-call-height ]
+ [
+ [ call-site-stack ] dip
+ [ check-call-site-stack ]
+ [ phi-in>> push ]
+ 2bi
+ ] 2bi ;
+
+: adjust-stack-effect ( effect -- effect' )
+ [ in>> ] [ out>> ] bi
+ meta-d get length pick length - object <repetition>
+ '[ , prepend ] bi@
+ <effect> ;
+
+: insert-copy ( effect -- )
+ in>> [ consume-d dup ] keep make-copies
+ [ nip output-d ] [ #copy, ] 2bi ;
+
+: call-recursive-inline-word ( word -- )
+ dup "recursive" word-prop [
+ [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
+ [ 2drop insert-copy ]
+ [ add-call drop ]
+ [ nip '[ , #call-recursive, ] consume/produce ]
+ 3tri
+ ] [ undeclared-recursion-error inference-error ] if ;
+
+: inline-word ( word -- )
+ [ +inlined+ depends-on ]
+ [
+ {
+ { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
+ { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
+ [ dup (inline-word) ]
+ } cond
+ ] bi ;
+
+M: word apply-object
+ dup inline? [ inline-word ] [ non-inline-word ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors alien alien.accessors arrays byte-arrays
+classes sequences.private continuations.private effects generic
+hashtables hashtables.private io io.backend io.files io.files.private
+io.streams.c kernel kernel.private math math.private memory
+namespaces namespaces.private parser prettyprint quotations
+quotations.private sbufs sbufs.private sequences
+sequences.private slots.private strings strings.private system
+threads.private classes.tuple classes.tuple.private vectors
+vectors.private words words.private assocs summary
+compiler.units system.private
+stack-checker.state stack-checker.backend stack-checker.branches
+stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.known-words
+
+: infer-shuffle ( shuffle -- )
+ [ in>> length consume-d ] keep ! inputs shuffle
+ [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+ [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+ #shuffle, ;
+
+: define-shuffle ( word shuffle -- )
+ '[ , infer-shuffle ] +infer+ set-word-prop ;
+
+{
+ { drop (( x -- )) }
+ { 2drop (( x y -- )) }
+ { 3drop (( x y z -- )) }
+ { dup (( x -- x x )) }
+ { 2dup (( x y -- x y x y )) }
+ { 3dup (( x y z -- x y z x y z )) }
+ { rot (( x y z -- y z x )) }
+ { -rot (( x y z -- z x y )) }
+ { dupd (( x y -- x x y )) }
+ { swapd (( x y z -- y x z )) }
+ { nip (( x y -- y )) }
+ { 2nip (( x y z -- z )) }
+ { tuck (( x y -- y x y )) }
+ { over (( x y -- x y x )) }
+ { pick (( x y z -- x y z x )) }
+ { swap (( x y -- y x )) }
+} [ define-shuffle ] assoc-each
+
+\ >r [ 1 infer->r ] +infer+ set-word-prop
+\ r> [ 1 infer-r> ] +infer+ set-word-prop
+
+
+\ declare [
+ pop-literal nip
+ [ length consume-d dup copy-values ] keep
+ #declare,
+] +infer+ set-word-prop
+
+! Primitive combinators
+GENERIC: infer-call* ( value known -- )
+
+: infer-call ( value -- ) dup known infer-call* ;
+
+M: literal infer-call*
+ [ 1array #drop, ] [ infer-literal-quot ] bi* ;
+
+M: curried infer-call*
+ swap push-d
+ [ uncurry ] recursive-state get infer-quot
+ [ quot>> known pop-d [ set-known ] keep ]
+ [ obj>> known pop-d [ set-known ] keep ] bi
+ push-d infer-call ;
+
+M: composed infer-call*
+ swap push-d
+ [ uncompose ] recursive-state get infer-quot
+ [ quot2>> known pop-d [ set-known ] keep ]
+ [ quot1>> known pop-d [ set-known ] keep ] bi
+ push-d push-d
+ [ slip call ] recursive-state get infer-quot ;
+
+M: object infer-call*
+ \ literal-expected inference-warning ;
+
+\ call [ pop-d infer-call ] +infer+ set-word-prop
+
+\ call t "no-compile" set-word-prop
+
+\ curry [
+ 2 consume-d
+ dup first2 <curried> make-known
+ [ push-d ] [ 1array ] bi
+ \ curry #call,
+] +infer+ set-word-prop
+
+\ compose [
+ 2 consume-d
+ dup first2 <composed> make-known
+ [ push-d ] [ 1array ] bi
+ \ compose #call,
+] +infer+ set-word-prop
+
+\ execute [
+ pop-literal nip
+ dup word? [
+ apply-object
+ ] [
+ drop
+ "execute must be given a word" time-bomb
+ ] if
+] +infer+ set-word-prop
+
+\ execute t "no-compile" set-word-prop
+
+\ if [
+ 2 consume-d
+ dup [ known [ curry? ] [ composed? ] bi or ] contains? [
+ output-d
+ [ rot [ drop call ] [ nip call ] if ]
+ recursive-state get infer-quot
+ ] [
+ [ #drop, ] [ [ literal ] map infer-if ] bi
+ ] if
+] +infer+ set-word-prop
+
+\ dispatch [
+ pop-literal nip [ <literal> ] map infer-dispatch
+] +infer+ set-word-prop
+
+\ dispatch t "no-compile" set-word-prop
+
+! Variadic tuple constructor
+\ <tuple-boa> [
+ \ <tuple-boa>
+ peek-d literal value>> size>> { tuple } <effect>
+ apply-word/effect
+] +infer+ set-word-prop
+
+! Non-standard control flow
+\ (throw) [
+ \ (throw)
+ peek-d literal value>> 2 + f <effect> t >>terminated?
+ apply-word/effect
+] +infer+ set-word-prop
+
+: set-primitive-effect ( word effect -- )
+ [ in>> "input-classes" set-word-prop ]
+ [ out>> "default-output-classes" set-word-prop ]
+ [ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ]
+ 2tri ;
+
+! Stack effects for all primitives
+\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum< make-foldable
+
+\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum<= make-foldable
+
+\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum> make-foldable
+
+\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum>= make-foldable
+
+\ eq? { object object } { object } <effect> set-primitive-effect
+\ eq? make-foldable
+
+\ rehash-string { string } { } <effect> set-primitive-effect
+
+\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
+\ bignum>fixnum make-foldable
+
+\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
+\ bignum>fixnum make-foldable
+
+\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
+\ fixnum>bignum make-foldable
+
+\ float>bignum { float } { bignum } <effect> set-primitive-effect
+\ float>bignum make-foldable
+
+\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
+\ fixnum>float make-foldable
+
+\ bignum>float { bignum } { float } <effect> set-primitive-effect
+\ bignum>float make-foldable
+
+\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
+\ <ratio> make-foldable
+
+\ string>float { string } { float } <effect> set-primitive-effect
+\ string>float make-foldable
+
+\ float>string { float } { string } <effect> set-primitive-effect
+\ float>string make-foldable
+
+\ float>bits { real } { integer } <effect> set-primitive-effect
+\ float>bits make-foldable
+
+\ double>bits { real } { integer } <effect> set-primitive-effect
+\ double>bits make-foldable
+
+\ bits>float { integer } { float } <effect> set-primitive-effect
+\ bits>float make-foldable
+
+\ bits>double { integer } { float } <effect> set-primitive-effect
+\ bits>double make-foldable
+
+\ <complex> { real real } { complex } <effect> set-primitive-effect
+\ <complex> make-foldable
+
+\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum+ make-foldable
+
+\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum+fast make-foldable
+
+\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum- make-foldable
+
+\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-fast make-foldable
+
+\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum* make-foldable
+
+\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum*fast make-foldable
+
+\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum/i make-foldable
+
+\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-mod make-foldable
+
+\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
+\ fixnum/mod make-foldable
+
+\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitand make-foldable
+
+\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitor make-foldable
+
+\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitxor make-foldable
+
+\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitnot make-foldable
+
+\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum-shift make-foldable
+
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-shift-fast make-foldable
+
+\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum= make-foldable
+
+\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum+ make-foldable
+
+\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum- make-foldable
+
+\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum* make-foldable
+
+\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum/i make-foldable
+
+\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-mod make-foldable
+
+\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
+\ bignum/mod make-foldable
+
+\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitand make-foldable
+
+\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitor make-foldable
+
+\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitxor make-foldable
+
+\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitnot make-foldable
+
+\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-shift make-foldable
+
+\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum< make-foldable
+
+\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum<= make-foldable
+
+\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum> make-foldable
+
+\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum>= make-foldable
+
+\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
+\ bignum-bit? make-foldable
+
+\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-log2 make-foldable
+
+\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
+\ byte-array>bignum make-foldable
+
+\ float= { float float } { object } <effect> set-primitive-effect
+\ float= make-foldable
+
+\ float+ { float float } { float } <effect> set-primitive-effect
+\ float+ make-foldable
+
+\ float- { float float } { float } <effect> set-primitive-effect
+\ float- make-foldable
+
+\ float* { float float } { float } <effect> set-primitive-effect
+\ float* make-foldable
+
+\ float/f { float float } { float } <effect> set-primitive-effect
+\ float/f make-foldable
+
+\ float< { float float } { object } <effect> set-primitive-effect
+\ float< make-foldable
+
+\ float-mod { float float } { float } <effect> set-primitive-effect
+\ float-mod make-foldable
+
+\ float<= { float float } { object } <effect> set-primitive-effect
+\ float<= make-foldable
+
+\ float> { float float } { object } <effect> set-primitive-effect
+\ float> make-foldable
+
+\ float>= { float float } { object } <effect> set-primitive-effect
+\ float>= make-foldable
+
+\ <word> { object object } { word } <effect> set-primitive-effect
+\ <word> make-flushable
+
+\ word-xt { word } { integer integer } <effect> set-primitive-effect
+\ word-xt make-flushable
+
+\ getenv { fixnum } { object } <effect> set-primitive-effect
+\ getenv make-flushable
+
+\ setenv { object fixnum } { } <effect> set-primitive-effect
+
+\ (exists?) { string } { object } <effect> set-primitive-effect
+
+\ (directory) { string } { array } <effect> set-primitive-effect
+
+\ gc { } { } <effect> set-primitive-effect
+
+\ gc-stats { } { array } <effect> set-primitive-effect
+
+\ save-image { string } { } <effect> set-primitive-effect
+
+\ save-image-and-exit { string } { } <effect> set-primitive-effect
+
+\ exit { integer } { } <effect> t >>terminated? set-primitive-effect
+
+\ data-room { } { integer integer array } <effect> set-primitive-effect
+\ data-room make-flushable
+
+\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
+\ code-room make-flushable
+
+\ os-env { string } { object } <effect> set-primitive-effect
+
+\ millis { } { integer } <effect> set-primitive-effect
+\ millis make-flushable
+
+\ tag { object } { fixnum } <effect> set-primitive-effect
+\ tag make-foldable
+
+\ cwd { } { string } <effect> set-primitive-effect
+
+\ cd { string } { } <effect> set-primitive-effect
+
+\ dlopen { string } { dll } <effect> set-primitive-effect
+
+\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
+
+\ dlclose { dll } { } <effect> set-primitive-effect
+
+\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
+\ <byte-array> make-flushable
+
+\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
+\ <displaced-alien> make-flushable
+
+\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-cell make-flushable
+
+\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-cell make-flushable
+
+\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-8 make-flushable
+
+\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-8 make-flushable
+
+\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-4 make-flushable
+
+\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-4 make-flushable
+
+\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-2 make-flushable
+
+\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-2 make-flushable
+
+\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-1 make-flushable
+
+\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-1 make-flushable
+
+\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-float make-flushable
+
+\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-double make-flushable
+
+\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
+\ alien-cell make-flushable
+
+\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
+
+\ alien-address { alien } { integer } <effect> set-primitive-effect
+\ alien-address make-flushable
+
+\ slot { object fixnum } { object } <effect> set-primitive-effect
+\ slot make-flushable
+
+\ set-slot { object object fixnum } { } <effect> set-primitive-effect
+
+\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
+\ string-nth make-flushable
+
+\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
+
+\ resize-array { integer array } { array } <effect> set-primitive-effect
+\ resize-array make-flushable
+
+\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
+\ resize-byte-array make-flushable
+
+\ resize-string { integer string } { string } <effect> set-primitive-effect
+\ resize-string make-flushable
+
+\ <array> { integer object } { array } <effect> set-primitive-effect
+\ <array> make-flushable
+
+\ begin-scan { } { } <effect> set-primitive-effect
+
+\ next-object { } { object } <effect> set-primitive-effect
+
+\ end-scan { } { } <effect> set-primitive-effect
+
+\ size { object } { fixnum } <effect> set-primitive-effect
+\ size make-flushable
+
+\ die { } { } <effect> set-primitive-effect
+
+\ fopen { string string } { alien } <effect> set-primitive-effect
+
+\ fgetc { alien } { object } <effect> set-primitive-effect
+
+\ fwrite { string alien } { } <effect> set-primitive-effect
+
+\ fputc { object alien } { } <effect> set-primitive-effect
+
+\ fread { integer string } { object } <effect> set-primitive-effect
+
+\ fflush { alien } { } <effect> set-primitive-effect
+
+\ fclose { alien } { } <effect> set-primitive-effect
+
+\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
+\ <wrapper> make-foldable
+
+\ (clone) { object } { object } <effect> set-primitive-effect
+\ (clone) make-flushable
+
+\ <string> { integer integer } { string } <effect> set-primitive-effect
+\ <string> make-flushable
+
+\ array>quotation { array } { quotation } <effect> set-primitive-effect
+\ array>quotation make-flushable
+
+\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
+\ quotation-xt make-flushable
+
+\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
+\ <tuple> make-flushable
+
+\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
+\ <tuple-layout> make-foldable
+
+\ datastack { } { array } <effect> set-primitive-effect
+\ datastack make-flushable
+
+\ retainstack { } { array } <effect> set-primitive-effect
+\ retainstack make-flushable
+
+\ callstack { } { callstack } <effect> set-primitive-effect
+\ callstack make-flushable
+
+\ callstack>array { callstack } { array } <effect> set-primitive-effect
+\ callstack>array make-flushable
+
+\ (sleep) { integer } { } <effect> set-primitive-effect
+
+\ become { array array } { } <effect> set-primitive-effect
+
+\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
+
+\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
+
+\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
+
+\ (os-envs) { } { array } <effect> set-primitive-effect
+
+\ set-os-env { string string } { } <effect> set-primitive-effect
+
+\ unset-os-env { string } { } <effect> set-primitive-effect
+
+\ (set-os-envs) { array } { } <effect> set-primitive-effect
+
+\ do-primitive [ \ do-primitive cannot-infer-effect ] +infer+ set-word-prop
+
+\ dll-valid? { object } { object } <effect> set-primitive-effect
+
+\ modify-code-heap { array object } { } <effect> set-primitive-effect
+
+\ unimplemented { } { } <effect> set-primitive-effect
--- /dev/null
+Hard-coded stack effects for primitive words
--- /dev/null
+USING: help.syntax help.markup kernel sequences words io
+effects classes math combinators
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.state ;
+IN: stack-checker
+
+ARTICLE: "inference-simple" "Straight-line stack effects"
+"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect."
+$nl
+"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect."
+{ $subsection d-in }
+{ $subsection meta-d }
+"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":"
+{ $example "[ 1 2 3 ] infer." "( -- object object object )" }
+"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:"
+{ $example "[ 2 + ] infer." "( object -- object )" }
+"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ;
+
+ARTICLE: "inference-combinators" "Combinator stack effects"
+"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
+{ $example "[ dup call ] infer." "... an error ..." }
+"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
+{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
+"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
+{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
+"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
+{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object object )" }
+"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
+$nl
+"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
+$nl
+"Here is an example where the stack effect cannot be inferred:"
+{ $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." }
+"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
+{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } ;
+
+ARTICLE: "inference-branches" "Branch stack effects"
+"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
+$nl
+"If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example,"
+{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" }
+"The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ;
+
+ARTICLE: "inference-recursive" "Stack effects of recursive words"
+"Recursive words must declare a stack effect. When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
+$nl
+"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
+{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." }
+"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
+
+ARTICLE: "inference-limitations" "Inference limitations"
+"Mutually recursive words are supported, but mutually recursive " { $emphasis "inline" } " words are not."
+$nl
+"An inline recursive word cannot pass a quotation through the recursive call. For example, the following will not infer:"
+{ $code ": foo ( a b c -- d e f ) [ f foo drop ] when 2dup call ; inline" "[ 1 [ 1+ ] foo ] infer." }
+"However a small change can be made:"
+{ $example ": foo ( a b c -- d ) [ 2dup f foo drop ] when call ; inline" "[ 1 [ 1+ ] t foo ] infer." "( -- object )" }
+"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
+{ $code
+ ": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline"
+ "[ [ 5 ] t foo ] infer."
+} ;
+
+ARTICLE: "compiler-transforms" "Compiler transforms"
+"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time."
+{ $subsection define-transform }
+"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "."
+$nl
+"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ;
+
+ARTICLE: "inference" "Stack effect inference"
+"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
+$nl
+"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
+{ $subsection infer. }
+"Instead of printing the inferred information, it can be returned as objects on the stack:"
+{ $subsection infer }
+"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
+$nl
+"The following articles describe the implementation of the stack effect inference algorithm:"
+{ $subsection "inference-simple" }
+{ $subsection "inference-combinators" }
+{ $subsection "inference-branches" }
+{ $subsection "inference-recursive" }
+{ $subsection "inference-limitations" }
+{ $subsection "inference-errors" }
+{ $subsection "compiler-transforms" }
+{ $see-also "effects" } ;
+
+ABOUT: "inference"
+
+HELP: inference-error
+{ $values { "class" class } }
+{ $description "Creates an instance of " { $snippet "class" } ", wraps it in an " { $link inference-error } " and throws the result." }
+{ $error-description
+ "Thrown by " { $link infer } " when the stack effect of a quotation cannot be inferred."
+ $nl
+ "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
+} ;
+
+
+HELP: infer
+{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
+{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+HELP: infer.
+{ $values { "quot" "a quotation" } }
+{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
+{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+
+{ infer infer. } related-words
+
+HELP: forget-errors
+{ $description "Removes markers indicating which words do not have stack effects."
+$nl
+"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
+{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
+{ $code "forget-errors" }
+"Subsequent invocations of the compiler will consider all words for compilation." } ;
--- /dev/null
+USING: accessors arrays generic stack-checker
+stack-checker.backend stack-checker.errors kernel classes
+kernel.private math math.parser math.private namespaces
+namespaces.private parser sequences strings vectors words
+quotations effects tools.test continuations generic.standard
+sorting assocs definitions prettyprint io inspector
+classes.tuple classes.union classes.predicate debugger
+threads.private io.streams.string io.timeouts io.thread
+sequences.private destructors combinators ;
+IN: stack-checker.tests
+
+{ 0 2 } [ 2 "Hello" ] must-infer-as
+{ 1 2 } [ dup ] must-infer-as
+
+{ 1 2 } [ [ dup ] call ] must-infer-as
+[ [ call ] infer ] must-fail
+
+{ 2 4 } [ 2dup ] must-infer-as
+
+{ 1 0 } [ [ ] [ ] if ] must-infer-as
+[ [ if ] infer ] must-fail
+[ [ [ ] if ] infer ] must-fail
+[ [ [ 2 ] [ ] if ] infer ] must-fail
+{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
+
+{ 4 3 } [
+ [
+ [ swap 3 ] [ nip 5 5 ] if
+ ] [
+ -rot
+ ] if
+] must-infer-as
+
+{ 1 1 } [ dup [ ] when ] must-infer-as
+{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as
+{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as
+
+{ 1 0 } [ [ drop ] when* ] must-infer-as
+{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as
+
+{ 0 1 }
+[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as
+
+[
+ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
+] must-fail
+
+! Test inference of termination of control flow
+: termination-test-1 ( -- * ) "foo" throw ;
+
+: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
+
+{ 1 1 } [ termination-test-2 ] must-infer-as
+
+: simple-recursion-1 ( obj -- obj )
+ dup [ simple-recursion-1 ] [ ] if ;
+
+{ 1 1 } [ simple-recursion-1 ] must-infer-as
+
+: simple-recursion-2 ( obj -- obj )
+ dup [ ] [ simple-recursion-2 ] if ;
+
+{ 1 1 } [ simple-recursion-2 ] must-infer-as
+
+: bad-recursion-2 ( obj -- obj )
+ dup [ dup first swap second bad-recursion-2 ] [ ] if ;
+
+[ [ bad-recursion-2 ] infer ] must-fail
+
+: funny-recursion ( obj -- obj )
+ dup [ funny-recursion 1 ] [ 2 ] if drop ;
+
+{ 1 1 } [ funny-recursion ] must-infer-as
+
+! Simple combinators
+{ 1 2 } [ [ first ] keep second ] must-infer-as
+
+! Mutual recursion
+DEFER: foe
+
+: fie ( element obj -- ? )
+ dup array? [ foe ] [ eq? ] if ;
+
+: foe ( element tree -- ? )
+ dup [
+ 2dup first fie [
+ nip
+ ] [
+ second dup array? [
+ foe
+ ] [
+ fie
+ ] if
+ ] if
+ ] [
+ 2drop f
+ ] if ;
+
+{ 2 1 } [ fie ] must-infer-as
+{ 2 1 } [ foe ] must-infer-as
+
+: nested-when ( -- )
+ t [
+ t [
+ 5 drop
+ ] when
+ ] when ;
+
+{ 0 0 } [ nested-when ] must-infer-as
+
+: nested-when* ( obj -- )
+ [
+ [
+ drop
+ ] when*
+ ] when* ;
+
+{ 1 0 } [ nested-when* ] must-infer-as
+
+SYMBOL: sym-test
+
+{ 0 1 } [ sym-test ] must-infer-as
+
+: terminator-branch ( a -- b )
+ dup [
+ length
+ ] [
+ "foo" throw
+ ] if ;
+
+{ 1 1 } [ terminator-branch ] must-infer-as
+
+: recursive-terminator ( obj -- )
+ dup [
+ recursive-terminator
+ ] [
+ "Hi" throw
+ ] if ;
+
+{ 1 0 } [ recursive-terminator ] must-infer-as
+
+GENERIC: potential-hang ( obj -- obj )
+M: fixnum potential-hang dup [ potential-hang ] when ;
+
+[ ] [ [ 5 potential-hang ] infer drop ] unit-test
+
+TUPLE: funny-cons car cdr ;
+GENERIC: iterate ( obj -- )
+M: funny-cons iterate funny-cons-cdr iterate ;
+M: f iterate drop ;
+M: real iterate drop ;
+
+{ 1 0 } [ iterate ] must-infer-as
+
+! Regression
+: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
+: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
+{ 3 0 } [ dog ] must-infer-as
+
+! Regression
+DEFER: monkey
+: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
+: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
+{ 3 0 } [ friend ] must-infer-as
+
+! Regression -- same as above but we infer the second word first
+DEFER: blah2
+: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
+: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
+{ 3 0 } [ blah2 ] must-infer-as
+
+! Regression
+DEFER: blah4
+: blah3 ( a b c -- )
+ dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
+: blah4 ( a b c -- )
+ dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
+{ 3 0 } [ blah4 ] must-infer-as
+
+! Regression
+: bad-combinator ( obj quot: ( -- ) -- )
+ over [
+ 2drop
+ ] [
+ [ swap slip ] keep swap bad-combinator
+ ] if ; inline recursive
+
+[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
+
+! Regression
+{ 2 2 } [
+ dup string? [ 2array throw ] unless
+ over string? [ 2array throw ] unless
+] must-infer-as
+
+! Regression
+
+! This order of branches works
+DEFER: do-crap
+: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
+: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
+[ [ do-crap ] infer ] must-fail
+
+! This one does not
+DEFER: do-crap*
+: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
+: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
+[ [ do-crap* ] infer ] must-fail
+
+! Regression
+: too-deep ( a b -- c )
+ dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
+{ 2 1 } [ too-deep ] must-infer-as
+
+! Error reporting is wrong
+MATH: xyz ( a b -- c )
+M: fixnum xyz 2array ;
+M: float xyz
+ [ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
+
+[ [ xyz ] infer ] [ inference-error? ] must-fail-with
+
+! Doug Coleman discovered this one while working on the
+! calendar library
+DEFER: A
+DEFER: B
+DEFER: C
+
+: A ( a -- )
+ dup {
+ [ drop ]
+ [ A ]
+ [ \ A no-method ]
+ [ dup C A ]
+ } dispatch ;
+
+: B ( b -- )
+ dup {
+ [ C ]
+ [ B ]
+ [ \ B no-method ]
+ [ dup B B ]
+ } dispatch ;
+
+: C ( c -- )
+ dup {
+ [ A ]
+ [ C ]
+ [ \ C no-method ]
+ [ dup B C ]
+ } dispatch ;
+
+{ 1 0 } [ A ] must-infer-as
+{ 1 0 } [ B ] must-infer-as
+{ 1 0 } [ C ] must-infer-as
+
+! I found this bug by thinking hard about the previous one
+DEFER: Y
+: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
+: Y ( a b -- c d ) X ;
+
+{ 2 2 } [ X ] must-infer-as
+{ 2 2 } [ Y ] must-infer-as
+
+! This one comes from UI code
+DEFER: #1
+: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
+: #3 ( a -- ) [ #1 ] #2 ;
+: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
+: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
+
+[ \ #4 def>> infer ] must-fail
+[ [ #1 ] infer ] must-fail
+
+! Similar
+DEFER: bar
+: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
+: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
+
+[ [ foo ] infer ] must-fail
+
+[ 1234 infer ] must-fail
+
+! This used to hang
+[ [ [ dup call ] dup call ] infer ]
+[ inference-error? ] must-fail-with
+
+: m dup call ; inline
+
+[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
+
+: m' dup curry call ; inline
+
+[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
+
+: m'' [ dup curry ] ; inline
+
+: m''' m'' call call ; inline
+
+[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
+
+: m-if t over if ; inline
+
+[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
+
+! This doesn't hang but it's also an example of the
+! undedicable case
+[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
+[ inference-error? ] must-fail-with
+
+! This form should not have a stack effect
+
+: bad-recursion-1 ( a -- b )
+ dup [ drop bad-recursion-1 5 ] [ ] if ;
+
+[ [ bad-recursion-1 ] infer ] must-fail
+
+: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
+[ [ bad-bin ] infer ] must-fail
+
+[ [ r> ] infer ] [ inference-error? ] must-fail-with
+
+! Regression
+[ [ cleave ] infer ] [ inference-error? ] must-fail-with
+
+! Test some curry stuff
+{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
+
+{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
+
+[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
+
+! Test number protocol
+\ bitor must-infer
+\ bitand must-infer
+\ bitxor must-infer
+\ mod must-infer
+\ /i must-infer
+\ /f must-infer
+\ /mod must-infer
+\ + must-infer
+\ - must-infer
+\ * must-infer
+\ / must-infer
+\ < must-infer
+\ <= must-infer
+\ > must-infer
+\ >= must-infer
+\ number= must-infer
+
+! Test object protocol
+\ = must-infer
+\ clone must-infer
+\ hashcode* must-infer
+
+! Test sequence protocol
+\ length must-infer
+\ nth must-infer
+\ set-length must-infer
+\ set-nth must-infer
+\ new must-infer
+\ new-resizable must-infer
+\ like must-infer
+\ lengthen must-infer
+
+! Test assoc protocol
+\ at* must-infer
+\ set-at must-infer
+\ new-assoc must-infer
+\ delete-at must-infer
+\ clear-assoc must-infer
+\ assoc-size must-infer
+\ assoc-like must-infer
+\ assoc-clone-like must-infer
+\ >alist must-infer
+{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
+
+! Test some random library words
+\ 1quotation must-infer
+\ string>number must-infer
+\ get must-infer
+
+\ push must-infer
+\ append must-infer
+\ peek must-infer
+
+\ reverse must-infer
+\ member? must-infer
+\ remove must-infer
+\ natural-sort must-infer
+
+\ forget must-infer
+\ define-class must-infer
+\ define-tuple-class must-infer
+\ define-union-class must-infer
+\ define-predicate-class must-infer
+\ instance? must-infer
+\ next-method-quot must-infer
+
+! Test words with continuations
+{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
+{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
+{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
+{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
+
+\ dispose must-infer
+
+! Test stream protocol
+\ set-timeout must-infer
+\ stream-read must-infer
+\ stream-read1 must-infer
+\ stream-readln must-infer
+\ stream-read-until must-infer
+\ stream-write must-infer
+\ stream-write1 must-infer
+\ stream-nl must-infer
+\ stream-format must-infer
+\ stream-write-table must-infer
+\ stream-flush must-infer
+\ make-span-stream must-infer
+\ make-block-stream must-infer
+\ make-cell-stream must-infer
+
+! Test stream utilities
+\ lines must-infer
+\ contents must-infer
+
+! Test prettyprinting
+\ . must-infer
+\ short. must-infer
+\ unparse must-infer
+
+\ describe must-infer
+\ error. must-infer
+
+! Test odds and ends
+\ io-thread must-infer
+
+! Incorrect stack declarations on inline recursive words should
+! be caught
+: fooxxx ( a b -- c ) over [ foo ] when ; inline
+: barxxx ( a b -- c ) fooxxx ;
+
+[ [ barxxx ] infer ] must-fail
+
+! A typo
+{ 1 0 } [ { [ ] } dispatch ] must-infer-as
+
+DEFER: inline-recursive-2
+: inline-recursive-1 ( -- ) inline-recursive-2 ;
+: inline-recursive-2 ( -- ) inline-recursive-1 ;
+
+{ 0 0 } [ inline-recursive-1 ] must-infer-as
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+{ 0 1 } [ my-hook ] must-infer-as
+
+DEFER: deferred-word
+
+{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
+
+
+DEFER: an-inline-word
+
+: normal-word-3 ( -- )
+ 3 [ [ 2 + ] curry ] an-inline-word call drop ;
+
+: normal-word-2 ( -- )
+ normal-word-3 ;
+
+: normal-word ( x -- x )
+ dup [ normal-word-2 ] when ;
+
+: an-inline-word ( obj quot -- )
+ >r normal-word r> call ; inline
+
+{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as
+
+{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
+
+ERROR: custom-error ;
+
+[ T{ effect f 0 0 t } ] [
+ [ custom-error ] infer
+] unit-test
+
+: funny-throw throw ; inline
+
+[ T{ effect f 0 0 t } ] [
+ [ 3 funny-throw ] infer
+] unit-test
+
+[ T{ effect f 0 0 t } ] [
+ [ custom-error inference-error ] infer
+] unit-test
+
+[ T{ effect f 1 1 t } ] [
+ [ dup >r 3 throw r> ] infer
+] unit-test
+
+! This was a false trigger of the undecidable quotation
+! recursion bug
+{ 2 1 } [ find-last-sep ] must-infer-as
+
+! Regression
+: missing->r-check >r ;
+
+[ [ missing->r-check ] infer ] must-fail
+
+! Corner case
+[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
+
+[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+
+[ [ erg's-inference-bug ] infer ] must-fail
+
+: inference-invalidation-a ( -- ) ;
+: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
+
+[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+
+{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
+
+[ 3 ] [ inference-invalidation-c ] unit-test
+
+{ 0 1 } [ inference-invalidation-c ] must-infer-as
+
+GENERIC: inference-invalidation-d ( obj -- )
+
+M: object inference-invalidation-d inference-invalidation-c 2drop ;
+
+\ inference-invalidation-d must-infer
+
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
+
+[ [ inference-invalidation-d ] infer ] must-fail
+
+: bad-recursion-3 ( -- ) dup [ >r bad-recursion-3 r> ] when ; inline
+[ [ bad-recursion-3 ] infer ] must-fail
+
+: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
+[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
+
+: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
+[ [ f [ ] bad-recursion-5 ] infer ] must-fail
+
+: bad-recursion-6 ( quot: ( -- ) -- )
+ dup bad-recursion-6 call ; inline recursive
+[ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io effects namespaces sequences quotations vocabs
+generic words stack-checker.backend stack-checker.state
+stack-checker.known-words stack-checker.transforms
+stack-checker.errors stack-checker.inlining
+stack-checker.visitor.dummy ;
+IN: stack-checker
+
+GENERIC: infer ( quot -- effect )
+
+M: callable infer ( quot -- effect )
+ [ recursive-state get infer-quot ] with-infer drop ;
+
+: infer. ( quot -- )
+ #! Safe to call from inference transforms.
+ infer effect>string print ;
+
+: forget-errors ( -- )
+ all-words [
+ dup subwords [ f +cannot-infer+ set-word-prop ] each
+ f +cannot-infer+ set-word-prop
+ ] each ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: stack-checker.state.tests
+USING: tools.test stack-checker.state words kernel namespaces
+definitions ;
+
+: computing-dependencies ( quot -- dependencies )
+ H{ } clone [ dependencies rot with-variable ] keep ;
+ inline
+
+SYMBOL: a
+SYMBOL: b
+
+[ ] [ a +called+ depends-on ] unit-test
+
+[ H{ { a +called+ } } ] [
+ [ a +called+ depends-on ] computing-dependencies
+] unit-test
+
+[ H{ { a +called+ } { b +inlined+ } } ] [
+ [
+ a +called+ depends-on b +inlined+ depends-on
+ ] computing-dependencies
+] unit-test
+
+[ H{ { a +inlined+ } { b +inlined+ } } ] [
+ [
+ a +inlined+ depends-on
+ a +called+ depends-on
+ b +inlined+ depends-on
+ ] computing-dependencies
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs namespaces sequences kernel definitions math
+effects accessors words stack-checker.errors ;
+IN: stack-checker.state
+
+: <value> ( -- value ) \ <value> counter ;
+
+SYMBOL: known-values
+
+: known ( value -- known ) known-values get at ;
+
+: set-known ( known value -- )
+ over [ known-values get set-at ] [ 2drop ] if ;
+
+: make-known ( known -- value )
+ <value> [ set-known ] keep ;
+
+: copy-value ( value -- value' )
+ known make-known ;
+
+: copy-values ( values -- values' )
+ [ copy-value ] map ;
+
+! Literal value
+TUPLE: literal < identity-tuple value recursion ;
+
+: <literal> ( obj -- value )
+ recursive-state get \ literal boa ;
+
+: literal ( value -- literal )
+ known dup literal?
+ [ \ literal-expected inference-warning ] unless ;
+
+! Result of curry
+TUPLE: curried obj quot ;
+
+C: <curried> curried
+
+! Result of compose
+TUPLE: composed quot1 quot2 ;
+
+C: <composed> composed
+
+! Did the current control-flow path throw an error?
+SYMBOL: terminated?
+
+! Number of inputs current word expects from the stack
+SYMBOL: d-in
+
+! Compile-time data stack
+SYMBOL: meta-d
+
+! Compile-time retain stack
+SYMBOL: meta-r
+
+: current-stack-height ( -- n ) meta-d get length d-in get - ;
+
+: current-effect ( -- effect )
+ d-in get
+ meta-d get length <effect>
+ terminated? get >>terminated? ;
+
+: init-inference ( -- )
+ terminated? off
+ V{ } clone meta-d set
+ V{ } clone meta-r set
+ 0 d-in set ;
+
+: init-known-values ( -- )
+ H{ } clone known-values set ;
+
+: copy-inference ( -- )
+ meta-d [ clone ] change
+ meta-r [ clone ] change
+ d-in [ ] change ;
+
+: recursive-label ( word -- label/f )
+ recursive-state get at ;
+
+: local-recursive-state ( -- assoc )
+ recursive-state get dup keys
+ [ dup word? [ inline? ] when not ] find drop
+ [ head-slice ] when* ;
+
+: inline-recursive-label ( word -- label/f )
+ local-recursive-state at ;
+
+: recursive-quotation? ( quot -- ? )
+ local-recursive-state [ first eq? ] with contains? ;
+
+! Words that the current quotation depends on
+SYMBOL: dependencies
+
+: depends-on ( word how -- )
+ swap dependencies get dup [
+ 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
+ ] [ 3drop ] if ;
+
+! Words we've inferred the stack effect of, for rollback
+SYMBOL: recorded
--- /dev/null
+Variables for holding stack effect inference state
--- /dev/null
+Stack effect inference
--- /dev/null
+tools
+compiler
--- /dev/null
+Slava Pestov
--- /dev/null
+Support for compile-time code transformation
--- /dev/null
+IN: stack-checker.transforms
+USING: help.markup help.syntax combinators words kernel ;
+
+HELP: define-transform
+{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
+{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." }
+{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:"
+{ $code ": ndrop ( n -- ) [ drop ] times ;" }
+"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:"
+{ $code "\\ ndrop [ \\ drop <repetition> >quotation ] 1 define-transform" }
+"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "."
+$nl
+"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
+{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
--- /dev/null
+IN: stack-checker.transforms.tests
+USING: sequences stack-checker.transforms tools.test math kernel
+quotations inference accessors combinators words arrays
+classes classes.tuple ;
+
+: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
+: compose-n ( quot -- ) compose-n-quot call ;
+\ compose-n [ compose-n-quot ] 2 define-transform
+: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
+
+[ 6 ] [ 1 2 3 compose-n-test ] unit-test
+
+TUPLE: color r g b ;
+
+C: <color> color
+
+: cleave-test ( color -- r g b )
+ { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+
+{ 1 3 } [ cleave-test ] must-infer-as
+
+[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
+
+[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test def>> call ] unit-test
+
+: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
+
+[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
+
+[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test def>> call ] unit-test
+
+: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
+
+[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
+
+[ 16 -3 1/6 ] [ 4 3 6 \ spread-test def>> call ] unit-test
+
+[ fixnum instance? ] must-infer
+
+: bad-new-test ( -- obj ) V{ } new ;
+
+[ bad-new-test ] must-infer
+
+[ bad-new-test ] must-fail
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors arrays kernel words sequences generic math
+namespaces quotations assocs combinators classes.tuple
+classes.tuple.private effects summary hashtables classes generic
+sets definitions generic.standard slots.private
+stack-checker.backend stack-checker.state stack-checker.errors ;
+IN: stack-checker.transforms
+
+: transform-quot ( quot n -- newquot )
+ dup zero? [
+ drop '[ recursive-state get @ ]
+ ] [
+ '[
+ , consume-d
+ [ first literal recursion>> ]
+ [ [ literal value>> ] each ] bi @
+ ]
+ ] if
+ '[ @ swap infer-quot ] ;
+
+: define-transform ( word quot n -- )
+ transform-quot +infer+ set-word-prop ;
+
+! Combinators
+\ cond [ cond>quot ] 1 define-transform
+
+\ case [
+ dup empty? [
+ drop [ no-case ]
+ ] [
+ dup peek quotation? [
+ dup peek swap but-last
+ ] [
+ [ no-case ] swap
+ ] if case>quot
+ ] if
+] 1 define-transform
+
+\ cleave [ cleave>quot ] 1 define-transform
+
+\ 2cleave [ 2cleave>quot ] 1 define-transform
+
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
+\ spread [ spread>quot ] 1 define-transform
+
+\ boa [
+ dup tuple-class? [
+ dup +inlined+ depends-on
+ [ "boa-check" word-prop ]
+ [ tuple-layout '[ , <tuple-boa> ] ]
+ bi append
+ ] [
+ \ boa \ no-method boa time-bomb
+ ] if
+] 1 define-transform
+
+\ (call-next-method) [
+ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
+
+! Deprecated
+\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform
+
+\ set-slots [ <reversed> [ get-slots ] curry ] 1 define-transform
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: stack-checker.visitor kernel ;
+IN: stack-checker.visitor.dummy
+
+M: f child-visitor f ;
+M: f #introduce, drop ;
+M: f #call, 3drop ;
+M: f #call-recursive, 3drop ;
+M: f #push, 2drop ;
+M: f #shuffle, 3drop ;
+M: f #>r, 2drop ;
+M: f #r>, 2drop ;
+M: f #return, 2drop ;
+M: f #terminate, ;
+M: f #if, 3drop ;
+M: f #dispatch, 2drop ;
+M: f #phi, 2drop 2drop ;
+M: f #declare, 3drop ;
+M: f #recursive, drop drop drop drop drop ;
+M: f #copy, 2drop ;
+M: f #drop, drop ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces ;
+IN: stack-checker.visitor
+
+SYMBOL: dataflow-visitor
+
+HOOK: child-visitor dataflow-visitor ( -- visitor )
+
+: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
+
+HOOK: #introduce, dataflow-visitor ( values -- )
+HOOK: #call, dataflow-visitor ( inputs outputs word -- )
+HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
+HOOK: #push, dataflow-visitor ( literal value -- )
+HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
+HOOK: #drop, dataflow-visitor ( values -- )
+HOOK: #>r, dataflow-visitor ( inputs outputs -- )
+HOOK: #r>, dataflow-visitor ( inputs outputs -- )
+HOOK: #terminate, dataflow-visitor ( -- )
+HOOK: #if, dataflow-visitor ( ? true false -- )
+HOOK: #dispatch, dataflow-visitor ( n branches -- )
+HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
+HOOK: #return, dataflow-visitor ( label stack -- )
+HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
+HOOK: #copy, dataflow-visitor ( inputs outputs -- )
projects / factor.git / commitdiff