dataflow optimizer work

library/bootstrap/boot-stage1.factor

@@ -15,14 +15,11 @@ parser prettyprint sequences io vectors words ;
     {
         "/version.factor"
 
-        "/library/stack.factor"
+        "/library/kernel.factor"
-        "/library/combinators.factor"
 
         "/library/collections/sequences.factor"
         "/library/collections/arrays.factor"
 
-        "/library/kernel.factor"
-
         "/library/math/math.factor"
         "/library/math/integer.factor"
         "/library/math/ratio.factor"
@@ -38,9 +35,9 @@ parser prettyprint sequences io vectors words ;
         "/library/collections/sbuf.factor"
         "/library/collections/assoc.factor"
         "/library/collections/lists.factor"
+        "/library/collections/vectors-epilogue.factor"
         "/library/collections/hashtables.factor"
         "/library/collections/namespaces.factor"
-        "/library/collections/vectors-epilogue.factor"
         "/library/collections/sequence-eq.factor"
         "/library/collections/slicing.factor"
         "/library/collections/strings-epilogue.factor"
@@ -87,12 +84,13 @@ parser prettyprint sequences io vectors words ;
         "/library/inference/inference.factor"
         "/library/inference/branches.factor"
         "/library/inference/words.factor"
-        "/library/inference/stack.factor"
         "/library/inference/recursive-values.factor"
         "/library/inference/class-infer.factor"
+        "/library/inference/kill-literals.factor"
         "/library/inference/optimizer.factor"
         "/library/inference/inline-methods.factor"
         "/library/inference/print-dataflow.factor"
+        "/library/inference/known-words.factor"
         
         "/library/compiler/assembler.factor"
         "/library/compiler/relocate.factor"

library/bootstrap/boot-stage3.factor

@@ -32,8 +32,6 @@ init-assembler
 
 : compile? "compile" get supported-cpu? and ;
 
-"library/inference/branches.factor" run-file
-
 compile? [
     \ car compile
     \ * compile

library/bootstrap/image.factor

@@ -22,9 +22,18 @@ strings vectors words ;
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
+! Object cache
+SYMBOL: objects
+
 ! Boot quotation, set by boot.factor
 SYMBOL: boot-quot
 
+! Image output format
+SYMBOL: big-endian
+SYMBOL: 64-bits
+
+SYMBOL: t-object
+
 : emit ( cell -- ) image get push ;
 
 : emit-seq ( seq -- ) image get swap nappend ;
@@ -36,8 +45,8 @@ SYMBOL: boot-quot
 : image-magic HEX: 0f0e0d0c ;
 : image-version 0 ;
 
-: cell "64-bits" get 8 4 ? ;
+: cell 64-bits get 8 4 ? ;
-: char "64-bits" get 4 2 ? ;
+: char 64-bits get 4 2 ? ;
 
 : untag ( cell tag -- ) tag-mask bitnot bitand ;
 : tag ( cell -- tag ) tag-mask bitand ;
@@ -56,12 +65,7 @@ SYMBOL: boot-quot
 
 ( Image header )
 
-: base
+: base 1024 ;
-    #! We relocate the image to after the header, and leaving
-    #! some empty cells. This lets us differentiate an F pointer
-    #! (0/tag 3) from a pointer to the first object in the
-    #! image.
-    64 cell * ;
 
 : header ( -- )
     image-magic emit
@@ -110,11 +114,11 @@ M: bignum ' ( bignum -- tagged )
     #! This can only emit 0, -1 and 1.
     bignum-tag here-as >r
     bignum-tag >header emit
-    [
+    {{
         [[ 0  [ 1 0   ] ]]
         [[ -1 [ 2 1 1 ] ]]
         [[ 1  [ 2 0 1 ] ]]
-    ] assoc unswons emit-fixnum [ emit ] each align-here r> ;
+    }} hash unswons emit-fixnum emit-seq align-here r> ;
 
 ( Special objects )
 
@@ -122,11 +126,11 @@ M: bignum ' ( bignum -- tagged )
 
 : t,
     object-tag here-as
-    dup t-offset fixup "t" set
+    dup t-offset fixup t-object set
     t-type >header emit
     0 ' emit ;
 
-M: t ' ( obj -- ptr ) drop "t" get ;
+M: t ' ( obj -- ptr ) drop t-object get ;
 M: f ' ( obj -- ptr )
     #! f is #define F RETAG(0,OBJECT_TYPE)
     drop object-tag ;
@@ -144,16 +148,15 @@ M: f ' ( obj -- ptr )
 ( Words )
 
 : emit-word ( word -- )
-    [
+    dup word-props ' >r
-        word-type >header ,
+    dup word-def ' >r
-        dup hashcode fixnum-tag immediate ,
+    object-tag here-as over objects get set-hash
-        0 ,
+    word-type >header emit
-        dup word-primitive ,
+    dup hashcode emit-fixnum
-        dup word-def ' ,
+    0 emit
-        dup word-props ' ,
+    word-primitive emit
-    ] make-vector
+    r> emit
-    swap object-tag here-as swap "objects" get set-hash
+    r> emit ;
-    [ emit ] each ;
 
 : word-error ( word msg -- )
     [ % dup word-vocabulary % " " % word-name % ] make-string
@@ -164,17 +167,16 @@ M: f ' ( obj -- ptr )
     dup dup word-name swap word-vocabulary unit search
     [ ] [ dup "Missing DEFER: " word-error ] ?ifte ;
 
-: pooled-object ( object -- ptr ) "objects" get hash ;
+: pooled-object ( object -- ptr ) objects get hash ;
 
 : fixup-word ( word -- offset )
-    dup pooled-object
+    transfer-word dup pooled-object dup
-    [ ] [ "Not in image: " word-error ] ?ifte ;
+    [ nip ] [ "Not in image: " word-error ] ifte ;
 
 : fixup-words ( -- )
     image get [ dup word? [ fixup-word ] when ] nmap ;
 
-M: word ' ( word -- pointer )
+M: word ' ( word -- pointer ) ;
-    transfer-word dup pooled-object [ ] [ ] ?ifte ;
 
 ( Wrappers )
 
@@ -194,7 +196,7 @@ M: cons ' ( c -- tagged )
 ( Strings )
 
 : emit-chars ( seq -- )
-    "big-endian" get [ [ reverse ] map ] unless
+    big-endian get [ [ reverse ] map ] unless
     [ 0 [ swap 16 shift + ] reduce emit ] each ;
 
 : pack-string ( string -- seq )
@@ -211,7 +213,7 @@ M: cons ' ( c -- tagged )
 M: string ' ( string -- pointer )
     #! We pool strings so that each string is only written once
     #! to the image
-    "objects" get [ emit-string ] cache ;
+    objects get [ emit-string ] cache ;
 
 ( Arrays and vectors )
 
@@ -226,7 +228,7 @@ M: string ' ( string -- pointer )
 M: tuple ' ( tuple -- pointer )
     <mirror> tuple-type emit-array ;
 
-: emit-vector ( vector -- pointer )
+M: vector ' ( vector -- pointer )
     dup array-type emit-array swap length
     object-tag here-as >r
     vector-type >header emit
@@ -234,21 +236,17 @@ M: tuple ' ( tuple -- pointer )
     emit ( array ptr )
     align-here r> ;
 
-M: vector ' ( vector -- pointer )
+( Hashes )
-    emit-vector ;
 
-: emit-hashtable ( hash -- pointer )
+M: hashtable ' ( hashtable -- pointer )
-    dup buckets>list array-type emit-array
+    dup buckets>vector array-type emit-array
-    swap hash>alist length
+    swap hash-size
     object-tag here-as >r
     hashtable-type >header emit
     emit-fixnum ( length )
     emit ( array ptr )
     align-here r> ;
 
-M: hashtable ' ( hashtable -- pointer )
-    "objects" get [ emit-hashtable ] cache ;
-
 ( End of the image )
 
 : words, ( -- )
@@ -264,6 +262,8 @@ M: hashtable ' ( hashtable -- pointer )
 : boot, ( quot -- )
     boot-quot get swap append ' boot-quot-offset fixup ;
 
+: heap-size image get length header-size - cell * ;
+
 : end ( quot -- )
     "Generating words..." print
     words,
@@ -273,12 +273,12 @@ M: hashtable ' ( hashtable -- pointer )
     boot,
     "Performing some word fixups..." print
     fixup-words
-    here base - heap-size-offset fixup ;
+    heap-size heap-size-offset fixup ;
 
 ( Image output )
 
 : (write-image) ( image -- )
-    "64-bits" get 8 4 ? swap "big-endian" get [
+    64-bits get 8 4 ? swap big-endian get [
         [ swap >be write ] each-with
     ] [
         [ swap >le write ] each-with
@@ -291,8 +291,10 @@ M: hashtable ' ( hashtable -- pointer )
 : with-minimal-image ( quot -- image )
     [
         800000 <vector> image set
-        <namespace> "objects" set
+        20000 <hashtable> objects set
         call
+        "Image length: " write image get length .
+        "Object cache size: " write objects get hash-size .
         image get
     ] with-scope ;
 
@@ -310,10 +312,10 @@ M: hashtable ' ( hashtable -- pointer )
     swap write-image ;
 
 : make-images ( -- )
-    "64-bits" off
+    64-bits off
-    "big-endian" off "boot.image.le32" make-image
+    big-endian off "boot.image.le32" make-image
-    "big-endian" on  "boot.image.be32" make-image
+    big-endian on  "boot.image.be32" make-image
-    "64-bits" on
+    64-bits on
-    "big-endian" off "boot.image.le64" make-image
+    big-endian off "boot.image.le64" make-image
-    "big-endian" on  "boot.image.be64" make-image
+    big-endian on  "boot.image.be64" make-image
-    "64-bits" off ;
+    64-bits off ;

library/collections/hashtables.factor

@@ -113,8 +113,8 @@ IN: hashtables
 : hash-clear ( hash -- )
     0 over set-hash-size [ f -rot set-hash-bucket ] each-bucket ;
 
-: buckets>list ( hash -- list )
+: buckets>vector ( hash -- vector )
-    hash-array >list ;
+    hash-array >vector ;
 
 : alist>hash ( alist -- hash )
     dup length 1 max <hashtable> swap

library/collections/sequences.factor

@@ -57,7 +57,7 @@ G: find* ( i seq quot -- i elt | quot: elt -- ? )
 
 : push ( element sequence -- )
     #! Push a value on the end of a sequence.
-    dup length swap set-nth ;
+    dup length swap set-nth ; inline
 
 : 2nth ( s s n -- x x ) tuck swap nth >r swap nth r> ; inline
 

library/collections/strings-epilogue.factor

@@ -4,9 +4,11 @@ IN: strings
 USING: generic kernel kernel-internals lists math namespaces
 sequences strings ;
 
-: empty-sbuf ( len -- sbuf ) dup <sbuf> [ set-length ] keep ;
+: empty-sbuf ( len -- sbuf )
+    dup <sbuf> [ set-length ] keep ; inline
 
-: fill ( count char -- string ) <repeated> >string ;
+: fill ( count char -- string )
+    <repeated> >string ; inline
 
 : padding ( string count char -- string )
     >r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] ifte ;
@@ -19,7 +21,8 @@ sequences strings ;
 
 : ch>string ( ch -- str ) 1 <sbuf> [ push ] keep (sbuf>string) ;
 
-: >sbuf ( seq -- sbuf ) dup length <sbuf> [ swap nappend ] keep ;
+: >sbuf ( seq -- sbuf )
+    dup length <sbuf> [ swap nappend ] keep ; inline
 
 M: object >string >sbuf (sbuf>string) ;
 

library/collections/vectors-epilogue.factor

@@ -5,10 +5,11 @@ math-internals sequences ;
 
 IN: vectors
 
-: empty-vector ( len -- vec ) dup <vector> [ set-length ] keep ;
+: empty-vector ( len -- vec )
+    dup <vector> [ set-length ] keep ; inline
 
 : >vector ( list -- vector )
-    dup length <vector> [ swap nappend ] keep ;
+    dup length <vector> [ swap nappend ] keep ; inline
 
 M: object thaw >vector ;
 

library/combinators.factor

@@ -1,68 +0,0 @@
-! Copyright (C) 2003, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel
-USING: words ;
-
-: slip ( quot x -- x | quot: -- )
-    >r call r> ; inline
-
-: 2slip ( quot x y -- x y | quot: -- )
-    >r >r call r> r> ; inline
-
-: keep ( x quot -- x | quot: x -- )
-    over >r call r> ; inline
-
-: 2keep ( x y quot -- x y | quot: x y -- )
-    over >r pick >r call r> r> ; inline
-
-: 3keep ( x y z quot -- x y z | quot: x y z -- )
-    >r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline
-
-: while ( quot generator -- )
-    #! Keep applying the quotation to the value produced by
-    #! calling the generator until the generator returns f.
-    2dup >r >r swap >r call dup [
-        r> call r> r> while
-    ] [
-        r> 2drop r> r> 2drop
-    ] ifte ; inline
-
-: ifte* ( cond true false -- | true: cond -- | false: -- )
-    #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
-    pick [ drop call ] [ 2nip call ] ifte ; inline
-
-: ?ifte ( default cond true false -- )
-    #! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte
-    >r >r dup [
-        nip r> r> drop call
-    ] [
-        drop r> drop r> call
-    ] ifte ; inline
-
-: unless ( cond quot -- | quot: -- )
-    #! Execute a quotation only when the condition is f. The
-    #! condition is popped off the stack.
-    [ ] swap ifte ; inline
-
-: unless* ( cond quot -- | quot: -- )
-    #! If cond is f, pop it off the stack and evaluate the
-    #! quotation. Otherwise, leave cond on the stack.
-    over [ drop ] [ nip call ] ifte ; inline
-
-: when ( cond quot -- | quot: -- )
-    #! Execute a quotation only when the condition is not f. The
-    #! condition is popped off the stack.
-    [ ] ifte ; inline
-
-: when* ( cond quot -- | quot: cond -- )
-    #! If the condition is true, it is left on the stack, and
-    #! the quotation is evaluated. Otherwise, the condition is
-    #! popped off the stack.
-    dupd [ drop ] ifte ; inline
-
-: with ( obj quot elt -- obj quot )
-    #! Utility word for each-with, map-with.
-    pick pick >r >r swap call r> r> ; inline
-
-: keep-datastack ( quot -- )
-    datastack slip set-datastack drop ;

library/compiler/intrinsics.factor

@@ -72,7 +72,7 @@ sequences vectors words ;
 : typed-literal? ( node -- ? )
     #! Output if the node's first input is well-typed, and the
     #! second is a literal.
-    dup node-peek safe-literal? swap node-peek-2 typed? and ;
+    dup node-peek literal? swap node-peek-2 typed? and ;
 
 \ slot [
     dup typed-literal? [
@@ -154,7 +154,7 @@ sequences vectors words ;
     0 0 %replace-d , ; inline
 
 : literal-fixnum? ( value -- ? )
-    dup safe-literal? [ literal-value fixnum? ] [ drop f ] ifte ;
+    dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
 
 : binary-op-imm ( imm op -- )
     1 %dec-d , in-1

library/compiler/linearizer.factor

@@ -58,7 +58,7 @@ M: object load-value ( vreg n value -- )
     literal-value dup
     immediate? [ %immediate ] [ %indirect ] ifte , ;
 
-M: safe-literal load-value ( vreg n value -- )
+M: literal load-value ( vreg n value -- )
     nip push-literal ;
 
 : push-1 ( value -- ) 0 swap push-literal ;

library/generic/tuple.factor

@@ -87,7 +87,7 @@ BUILTIN: tuple 18 tuple? ;
 : (hash>quot) ( default hash -- quot )
     [
         \ dup , \ hashcode , dup bucket-count , \ rem ,
-        buckets>list [ alist>quot ] map-with >vector ,
+        buckets>vector [ alist>quot ] map-with ,
         \ dispatch ,
     ] make-list ;
 

library/inference/branches.factor

@@ -10,6 +10,9 @@ namespaces prettyprint sequences strings unparser vectors words ;
     dup max-length swap
     [ [ required-inputs ] keep append ] map-with ;
 
+: unify-length ( seq seq -- seq )
+    2vector unify-lengths 2unseq ;
+
 : unify-values ( seq -- value )
     #! If all values in list are equal, return the value.
     #! Otherwise, unify.
@@ -86,15 +89,3 @@ namespaces prettyprint sequences strings unparser vectors words ;
     #! base case to this stack effect and try again.
     [ >r (infer-branches) r> set-node-children ] keep
     node, #merge node, ;
-
-\ ifte [
-    2 #drop node, pop-d pop-d swap 2vector
-    #ifte pop-d drop infer-branches
-] "infer" set-word-prop
-
-USE: kernel-internals
-
-\ dispatch [
-    pop-literal nip [ <literal> ] map
-    #dispatch pop-d drop infer-branches
-] "infer" set-word-prop

library/inference/class-infer.factor

@@ -115,9 +115,7 @@ M: #call infer-classes* ( node -- )
     ] ifte ;
 
 M: #push infer-classes* ( node -- )
-    node-out-d [ safe-literal? ] subset
+    node-out-d dup [ literal-value ] map swap assume-literals ;
-    dup [ literal-value ] map
-    swap assume-literals ;
 
 M: #ifte child-ties ( node -- seq )
     node-in-d first dup general-t <class-tie>

library/inference/dataflow.factor

@@ -4,6 +4,43 @@ IN: inference
 USING: generic interpreter kernel lists namespaces parser
 sequences vectors words ;
 
+! Recursive state. An alist, mapping words to labels.
+SYMBOL: recursive-state
+
+TUPLE: value recursion uid ;
+
+C: value ( -- value )
+    gensym over set-value-uid
+    recursive-state get over set-value-recursion ;
+
+M: value = eq? ;
+
+TUPLE: computed ;
+
+C: computed ( -- value ) <value> over set-delegate ;
+
+TUPLE: literal value ;
+
+C: literal ( obj -- value )
+    <value> over set-delegate
+    [ set-literal-value ] keep ;
+
+TUPLE: meet values ;
+
+C: meet ( values -- value )
+    <value> over set-delegate [ set-meet-values ] keep ;
+
+: value-refers? ( referee referrer -- ? )
+    2dup eq? [
+        2drop t
+    ] [
+        dup meet? [
+            meet-values [ value-refers? ] contains-with?
+        ] [
+            2drop f
+        ] ifte
+    ] ifte ;
+
 ! The dataflow IR is the first of the two intermediate
 ! representations used by Factor. It annotates concatenative
 ! code with stack flow information and types.
@@ -121,7 +158,8 @@ SYMBOL: current-node
         dup node-in-r % node-out-r %
     ] make-vector ;
 
-: uses-value? ( value node -- ? ) node-values memq? ;
+: uses-value? ( value node -- ? )
+    node-values [ value-refers? ] contains-with? ;
 
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;
@@ -137,9 +175,6 @@ SYMBOL: current-node
 : drop-inputs ( node -- #drop )
     node-in-d clone in-d-node <#drop> ;
 
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
-
 : each-node ( node quot -- )
     over [
         [ call ] 2keep swap
@@ -151,3 +186,54 @@ SYMBOL: recursive-state
 
 : each-node-with ( obj node quot -- | quot: obj node -- )
     swap [ with ] each-node 2drop ; inline
+
+SYMBOL: substituted
+
+DEFER: subst-value
+
+: subst-meet ( new old meet -- )
+    #! We avoid mutating the same meet more than once, since
+    #! doing so can introduce cycles.
+    dup substituted get memq? [
+        3drop
+    ] [
+        dup substituted get push meet-values subst-value
+    ] ifte ;
+
+: (subst-value) ( new old value -- value )
+    2dup eq? [
+        2drop
+    ] [
+        dup meet? [
+            pick over eq? [
+                2nip ! don't substitute a meet into itself
+            ] [
+                [ subst-meet ] keep
+            ] ifte
+        ] [
+            2nip
+        ] ifte
+    ] ifte ;
+
+: subst-value ( new old seq -- )
+    pick pick eq? over empty? or [
+        3drop
+    ] [
+        [ >r 2dup r> (subst-value) ] nmap 2drop
+    ] ifte ;
+
+: (subst-values) ( newseq oldseq seq -- )
+    #! Mutates seq.
+    -rot [ pick subst-value ] 2each drop ;
+
+: subst-values ( new old node -- )
+    #! Mutates the node.
+    [
+        10 <vector> substituted set [
+            3dup node-in-d  (subst-values)
+            3dup node-in-r  (subst-values)
+            3dup node-out-d (subst-values)
+            3dup node-out-r (subst-values)
+            drop
+        ] each-node 2drop
+    ] with-scope ;

library/inference/inference.factor

@@ -19,24 +19,6 @@ M: inference-error error. ( error -- )
     "! Recursive state:" print
     inference-error-rstate [.] ;
 
-TUPLE: value recursion safe? ;
-
-C: value ( -- value )
-    t over set-value-safe?
-    recursive-state get over set-value-recursion ;
-
-M: value = eq? ;
-
-TUPLE: computed ;
-
-C: computed ( -- value ) <value> over set-delegate ;
-
-TUPLE: literal value ;
-
-C: literal ( obj -- value )
-    <value> over set-delegate
-    [ set-literal-value ] keep ;
-
 M: value literal-value ( value -- )
     {
         "A literal value was expected where a computed value was found.\n"
@@ -46,40 +28,6 @@ M: value literal-value ( value -- )
         "is marked 'inline'. See the handbook for details."
     } concat inference-error ;
 
-TUPLE: meet values ;
-
-C: meet ( values -- value )
-    <value> over set-delegate [ set-meet-values ] keep ;
-
-PREDICATE: tuple safe-literal ( obj -- ? )
-    dup literal? [ value-safe? ] [ drop f ] ifte ;
-
-DEFER: subst-value
-
-: (subst-value) ( new old value -- value )
-    dup meet? [
-        [ meet-values subst-value ] keep
-    ] [
-        tuck eq? [ drop ] [ nip ] ifte
-    ] ifte ;
-
-: subst-value ( new old seq -- )
-    [ >r 2dup r> (subst-value) ] nmap 2drop ;
-
-: (subst-values) ( newseq oldseq seq -- )
-    #! Mutates seq.
-    -rot [ pick subst-value ] 2each drop ;
-
-: subst-values ( new old node -- )
-    #! Mutates the node.
-    [
-        3dup node-in-d  (subst-values)
-        3dup node-in-r  (subst-values)
-        3dup node-out-d (subst-values)
-        3dup node-out-r (subst-values)
-        drop
-    ] each-node 2drop ;
-
 ! Word properties that affect inference:
 ! - infer-effect -- must be set. controls number of inputs
 ! expected, and number of outputs produced.

library/inference/inline-methods.factor

@@ -19,17 +19,12 @@ M: simple-generic dispatching-values drop node-in-d peek 1vector ;
 
 M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 
-: safe-node-classes ( node seq -- seq )
+: node-classes* ( node seq -- seq )
-    >r node-classes r> [
+    >r node-classes r>
-        dup value-safe? [
+    [ swap ?hash [ object ] unless* ] map-with ;
-            swap ?hash [ object ] unless*
-        ] [
-            2drop object
-        ] ifte
-    ] map-with ;
 
 : dispatching-classes ( node -- seq )
-    dup dup node-param dispatching-values safe-node-classes ;
+    dup dup node-param dispatching-values node-classes* ;
 
 : inlining-class ( #call -- class )
     #! If the generic dispatch can be eliminated, return the
@@ -76,7 +71,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 
 : optimize-predicate? ( #call -- ? )
     dup node-param "predicating" word-prop dup [
-        >r dup node-in-d safe-node-classes first r> related?
+        >r dup node-in-d node-classes* first r> related?
     ] [
         2drop f
     ] ifte ;
@@ -92,7 +87,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 
 : optimize-predicate ( #call -- node )
     dup node-param "predicating" word-prop >r
-    dup dup node-in-d safe-node-classes first r> class<
+    dup dup node-in-d node-classes* first r> class<
     inline-literal ;
 
 M: #call optimize-node* ( node -- node/t )

library/inference/kill-literals.factor

@@ -0,0 +1,155 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: generic hashtables inference kernel lists
+matrices namespaces sequences vectors ;
+
+GENERIC: literals* ( node -- )
+
+: literals ( node -- seq )
+    [ [ literals* ] each-node ] make-vector ;
+
+GENERIC: can-kill* ( literal node -- ? )
+
+: can-kill? ( literal node -- ? )
+    #! Return false if the literal appears in any node in the
+    #! list.
+    dup [
+        2dup can-kill*
+        [ node-successor can-kill? ] [ 2drop f ] ifte
+    ] [
+        2drop t
+    ] ifte ;
+
+: kill-set ( node -- list )
+    #! Push a list of literals that may be killed in the IR.
+    dup literals [ swap can-kill? ] subset-with ;
+
+: remove-values ( values node -- )
+    2dup [ node-in-d seq-diff ] keep set-node-in-d
+    2dup [ node-out-d seq-diff ] keep set-node-out-d
+    2dup [ node-in-r seq-diff ] keep set-node-in-r
+    [ node-out-r seq-diff ] keep set-node-out-r ;
+
+GENERIC: kill-node* ( literals node -- )
+
+M: node kill-node* ( literals node -- ) 2drop ;
+
+: kill-node ( literals node -- )
+    [ 2dup kill-node* remove-values ] each-node-with ;
+
+! Generic nodes
+M: node literals* ( node -- ) drop ;
+
+M: node can-kill* ( literal node -- ? ) uses-value? not ;
+
+! #push
+M: #push literals* ( node -- )
+    node-out-d % ;
+
+M: #push can-kill* ( literal node -- ? )
+    2drop t ;
+
+M: #push kill-node* ( literals node -- )
+    [ node-out-d seq-diff ] keep set-node-out-d ;
+
+! #drop
+M: #drop can-kill* ( literal node -- ? )
+    2drop t ;
+
+! #call
+: (kill-shuffle) ( word -- map )
+    {{
+        [[ dup {{ }} ]]
+        [[ drop {{ }} ]]
+        [[ swap {{ }} ]]
+        [[ over
+            {{
+                [[ { f t } dup  ]]
+            }}
+        ]]
+        [[ pick
+            {{
+                [[ { f f t } over ]]
+                [[ { f t f } over ]]
+                [[ { f t t } dup  ]]
+            }}
+        ]]
+        [[ >r {{ }} ]]
+        [[ r> {{ }} ]]
+    }} hash ;
+
+M: #call can-kill* ( literal node -- ? )
+    dup node-param (kill-shuffle) >r delegate can-kill* r> or ;
+
+: kill-mask ( killing node -- mask )
+    dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
+    [ swap memq? ] map-with ;
+
+: lookup-mask ( mask word -- word )
+    over disj [ (kill-shuffle) hash ] [ nip ] ifte ;
+
+: kill-shuffle ( literals node -- )
+    #! If certain values passing through a stack op are being
+    #! killed, the stack op can be reduced, in extreme cases
+    #! to a no-op.
+    [ [ kill-mask ] keep node-param lookup-mask ] keep
+    set-node-param ;
+
+M: #call kill-node* ( literals node -- )
+    dup node-param (kill-shuffle)
+    [ kill-shuffle ] [ 2drop ] ifte ;
+
+! #call-label
+M: #call-label can-kill* ( literal node -- ? )
+     2drop t ;
+
+! #label
+M: #label can-kill* ( literal node -- ? )
+    node-children first can-kill? ;
+
+M: #simple-label can-kill* ( literal node -- ? )
+    node-children first can-kill? ;
+
+! #ifte
+SYMBOL: branch-returns
+
+: branch-values ( branches -- )
+    [ last-node node-in-d ] map
+    unify-lengths flip branch-returns set ;
+
+: can-kill-branches? ( literal node -- ? )
+    #! Check if the literal appears in either branch. This
+    #! assumes that the last element of each branch is a #values
+    #! node.
+    2dup uses-value? [
+        2drop f
+    ] [
+        [
+            node-children dup branch-values
+            [ can-kill? ] all-with?
+        ] with-scope
+    ] ifte ;
+
+M: #ifte can-kill* ( literal node -- ? )
+    can-kill-branches? ;
+
+! #dispatch
+M: #dispatch can-kill* ( literal node -- ? )
+    can-kill-branches? ;
+
+! #values
+M: #values can-kill* ( literal node -- ? )
+    dupd uses-value? [
+        branch-returns get
+        [ memq? ] subset-with
+        [ [ eq? ] every? ] all?
+    ] [
+        drop t
+    ] ifte ;
+
+! #merge
+M: #merge can-kill* ( literal node -- ? ) 2drop t ;
+
+! #entry
+M: #entry can-kill* ( literal node -- ? ) 2drop t ;

library/inference/known-words.factor

@@ -0,0 +1,91 @@
+IN: inference
+
+! Primitive combinators
+\ call [
+    pop-literal infer-quot-value
+] "infer" set-word-prop
+
+\ execute [
+    pop-literal unit infer-quot-value
+] "infer" set-word-prop
+
+\ ifte [
+    2 #drop node, pop-d pop-d swap 2vector
+    #ifte pop-d drop infer-branches
+] "infer" set-word-prop
+
+\ dispatch [
+    pop-literal nip [ <literal> ] map
+    #dispatch pop-d drop infer-branches
+] "infer" set-word-prop
+
+! Stack manipulation
+\ >r [
+    \ >r #call
+    1 0 pick node-inputs
+    pop-d push-r
+    0 1 pick node-outputs
+    node,
+] "infer" set-word-prop
+
+\ r> [
+    \ r> #call
+    0 1 pick node-inputs
+    pop-r push-d
+    1 0 pick node-outputs
+    node,
+] "infer" set-word-prop
+
+\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
+\ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
+\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
+\ over [ \ over infer-shuffle ] "infer" set-word-prop
+\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
+
+! Type conversion
+{
+    { >boolean boolean      }
+    { >list    general-list }
+    { >bignum  bignum       }
+    { >fixnum  fixnum       }
+    { >float   float        }
+    { >sbuf    sbuf         }
+    { >string  string       }
+    { >vector  vector       }
+} [ 2unseq "converter" set-word-prop ] each
+
+! These hacks will go away soon
+\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
+\ no-method t "terminator" set-word-prop
+\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
+\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
+\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
+\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
+\ not-a-number t "terminator" set-word-prop
+\ inference-error t "terminator" set-word-prop
+\ throw t "terminator" set-word-prop
+\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
+\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
+\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
+\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
+\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
+\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
+\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
+\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
+\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
+\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

library/inference/optimizer.factor

@@ -8,51 +8,10 @@ matrices namespaces sequences vectors ;
 ! label scopes, to prevent infinite loops when inlining
 ! recursive methods.
 
-GENERIC: literals* ( node -- )
-
-: literals ( node -- seq )
-    [ [ literals* ] each-node ] make-vector ;
-
-GENERIC: can-kill* ( literal node -- ? )
-
-: can-kill? ( literal node -- ? )
-    #! Return false if the literal appears in any node in the
-    #! list.
-    dup [
-        2dup can-kill*
-        [ node-successor can-kill? ] [ 2drop f ] ifte
-    ] [
-        2drop t
-    ] ifte ;
-
-: kill-set ( node -- list )
-    #! Push a list of literals that may be killed in the IR.
-    dup literals [ swap can-kill? ] subset-with ;
-
-: remove-values ( values node -- )
-    2dup [ node-in-d seq-diff ] keep set-node-in-d
-    2dup [ node-out-d seq-diff ] keep set-node-out-d
-    2dup [ node-in-r seq-diff ] keep set-node-in-r
-    [ node-out-r seq-diff ] keep set-node-out-r ;
-
-GENERIC: kill-node* ( literals node -- )
-
-M: node kill-node* ( literals node -- ) 2drop ;
-
-: kill-node ( literals node -- )
-    [ 2dup kill-node* remove-values ] each-node-with ;
-
 GENERIC: optimize-node* ( node -- node )
 
-DEFER: optimize-node ( node -- node/t )
-
 GENERIC: optimize-children
 
-M: node optimize-children ( node -- )
-    f swap [
-        node-children [ optimize-node swap >r or r> ] map
-    ] keep set-node-children ;
-
 : keep-optimizing ( node -- node ? )
     dup optimize-node* dup t =
     [ drop f ] [ nip keep-optimizing t or ] ifte ;
@@ -65,94 +24,42 @@ M: node optimize-children ( node -- )
         over set-node-successor r> r> r> or or
     ] [ r> ] ifte ;
 
+M: node optimize-children ( node -- )
+    f swap [
+        node-children [ optimize-node swap >r or r> ] map
+    ] keep set-node-children ;
+
+: optimize-loop ( dataflow -- dataflow )
+    recursive-state off
+    dup kill-set over kill-node
+    dup infer-classes
+    optimize-node [ optimize-loop ] when ;
+
 : optimize ( dataflow -- dataflow )
-    #! Remove redundant literals from the IR. The original IR
-    #! is destructively modified.
     [
-        recursive-state off
         dup solve-recursion
-        dup kill-set over kill-node
+        optimize-loop
-        dup infer-classes
+    ] with-scope ;
-        optimize-node
-    ] with-scope [ optimize ] when ;
 
 : prune-if ( node quot -- successor/t )
     over >r call [ r> node-successor ] [ r> drop t ] ifte ;
     inline
 
 ! Generic nodes
-M: node literals* ( node -- ) drop ;
-
-M: node can-kill* ( literal node -- ? ) uses-value? not ;
-
 M: f optimize-node* drop t ;
 
 M: node optimize-node* ( node -- t )
     drop t ;
 
 ! #push
-M: #push literals* ( node -- )
-    node-out-d % ;
-
-M: #push can-kill* ( literal node -- ? )
-    2drop t ;
-
-M: #push kill-node* ( literals node -- )
-    [ node-out-d seq-diff ] keep set-node-out-d ;
-
 M: #push optimize-node* ( node -- node/t )
     [ node-out-d empty? ] prune-if ;
 
 ! #drop
-M: #drop can-kill* ( literal node -- ? )
-    2drop t ;
-
 M: #drop optimize-node*  ( node -- node/t )
     [ node-in-d empty? ] prune-if ;
 
 ! #call
-: (kill-shuffle) ( word -- map )
-    {{
-        [[ dup {{ }} ]]
-        [[ drop {{ }} ]]
-        [[ swap {{ }} ]]
-        [[ over
-            {{
-                [[ { f t } dup  ]]
-            }}
-        ]]
-        [[ pick
-            {{
-                [[ { f f t } over ]]
-                [[ { f t f } over ]]
-                [[ { f t t } dup  ]]
-            }}
-        ]]
-        [[ >r {{ }} ]]
-        [[ r> {{ }} ]]
-    }} hash ;
-
-M: #call can-kill* ( literal node -- ? )
-    dup node-param (kill-shuffle) >r delegate can-kill* r> or ;
-
-: kill-mask ( killing node -- mask )
-    dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
-    [ swap memq? ] map-with ;
-
-: lookup-mask ( mask word -- word )
-    over disj [ (kill-shuffle) hash ] [ nip ] ifte ;
-
-: kill-shuffle ( literals node -- )
-    #! If certain values passing through a stack op are being
-    #! killed, the stack op can be reduced, in extreme cases
-    #! to a no-op.
-    [ [ kill-mask ] keep node-param lookup-mask ] keep
-    set-node-param ;
-
-M: #call kill-node* ( literals node -- )
-    dup node-param (kill-shuffle)
-    [ kill-shuffle ] [ 2drop ] ifte ;
-
 : optimize-not? ( #call -- ? )
     dup node-param \ not =
     [ node-successor #ifte? ] [ drop f ] ifte ;
@@ -160,17 +67,7 @@ M: #call kill-node* ( literals node -- )
 : flip-branches ( #ifte -- )
     dup node-children 2unseq swap 2vector swap set-node-children ;
 
-! #call-label
-M: #call-label can-kill* ( literal node -- ? )
-     2drop t ;
-
 ! #label
-M: #label can-kill* ( literal node -- ? )
-    node-children first can-kill? ;
-
-M: #simple-label can-kill* ( literal node -- ? )
-    node-children first can-kill? ;
-
 : optimize-label ( node -- node )
     dup node-param recursive-state [ cons ] change
     delegate optimize-children
@@ -181,27 +78,8 @@ M: #label optimize-children optimize-label ;
 M: #simple-label optimize-children optimize-label ;
 
 ! #ifte
-SYMBOL: branch-returns
-
-: branch-values ( branches -- )
-    [ last-node node-in-d ] map
-    unify-lengths flip branch-returns set ;
-
-: can-kill-branches? ( literal node -- ? )
-    #! Check if the literal appears in either branch. This
-    #! assumes that the last element of each branch is a #values
-    #! node.
-    2dup uses-value? [
-        2drop f
-    ] [
-        [
-            node-children dup branch-values
-            [ can-kill? ] all-with?
-        ] with-scope
-    ] ifte ;
-
 : static-branch? ( node -- lit ? )
-    node-in-d first dup safe-literal? ;
+    node-in-d first dup literal? ;
 
 : static-branch ( conditional n -- node )
     >r [ drop-inputs ] keep r>
@@ -209,29 +87,13 @@ SYMBOL: branch-returns
     over node-successor over last-node set-node-successor
     pick set-node-successor drop ;
 
-M: #ifte can-kill* ( literal node -- ? )
-    can-kill-branches? ;
-
 M: #ifte optimize-node* ( node -- node )
     dup static-branch?
     [ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ;
 
-! #dispatch
-M: #dispatch can-kill* ( literal node -- ? )
-    can-kill-branches? ;
-
 ! #values
-M: #values can-kill* ( literal node -- ? )
-    dupd uses-value? [
-        branch-returns get
-        [ memq? ] subset-with
-        [ [ eq? ] every? ] all?
-    ] [
-        drop t
-    ] ifte ;
-
 : values/merge ( #values #merge -- new old )
-    >r >r node-in-d r> node-in-d 2vector unify-lengths 2unseq r> ;
+    >r >r node-in-d r> node-in-d unify-length r> ;
 
 : post-split ( #values -- node )
     #! If a #values is followed by a #merge, we need to replace
@@ -242,9 +104,3 @@ M: #values can-kill* ( literal node -- ? )
 
 M: #values optimize-node* ( node -- node ? )
     dup node-successor #merge? [ post-split ] [ drop t ] ifte ;
-
-! #merge
-M: #merge can-kill* ( literal node -- ? ) 2drop t ;
-
-! #entry
-M: #entry can-kill* ( literal node -- ? ) 2drop t ;

library/inference/recursive-values.factor

@@ -22,8 +22,8 @@ M: node solve-recursion* ( node -- ) drop ;
 M: #label solve-recursion* ( node -- )
     dup node-param over collect-recursion >r
     node-children first dup node-in-d r> swap add
-    unify-stacks swap [ node-in-d ] keep 
+    unify-stacks swap [ node-in-d unify-length ] keep
-    node-successor dup . subst-values ;
+    subst-values ;
 
 : solve-recursion ( node -- )
     #! Figure out which values survive inner recursions in

library/inference/stack.factor

@@ -1,39 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: interpreter kernel namespaces sequences words ;
-
-\ >r [
-    \ >r #call
-    1 0 pick node-inputs
-    pop-d push-r
-    0 1 pick node-outputs
-    node,
-] "infer" set-word-prop
-
-\ r> [
-    \ r> #call
-    0 1 pick node-inputs
-    pop-r push-d
-    1 0 pick node-outputs
-    node,
-] "infer" set-word-prop
-
-: with-datastack ( stack word -- stack )
-    datastack >r >r set-datastack r> execute
-    datastack r> [ push ] keep set-datastack 2nip ;
-
-: apply-datastack ( word -- )
-    meta-d [ swap with-datastack ] change ;
-
-: infer-shuffle ( word -- )
-    dup #call [
-        over "infer-effect" word-prop
-        [ apply-datastack ] hairy-node
-    ] keep node, ;
-
-\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
-\ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
-\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
-\ over [ \ over infer-shuffle ] "infer" set-word-prop
-\ pick [ \ pick infer-shuffle ] "infer" set-word-prop

library/inference/words.factor

@@ -25,9 +25,6 @@ hashtables parser prettyprint ;
     " was already attempted, and failed" append3
     inference-error ;
 
-: inhibit-parital ( -- )
-    meta-d get [ f swap set-value-safe? ] each ;
-
 : recursive? ( word -- ? )
     f swap dup word-def [ = or ] tree-each-with ;
 
@@ -39,9 +36,8 @@ hashtables parser prettyprint ;
     recursive-state [ cdr ] change ; inline
 
 : inline-block ( word -- node-block )
-    gensym over word-def cons [
+    gensym over word-def cons
-        #entry node,  inhibit-parital  word-def infer-quot
+    [ #entry node,  word-def infer-quot ] with-block ;
-    ] with-block ;
 
 : inline-compound ( word -- )
     #! Infer the stack effect of a compound word in the current
@@ -147,46 +143,15 @@ M: compound apply-object ( word -- )
         ] ifte
     ] ifte* ;
 
-\ call [
+: with-datastack ( stack word -- stack )
-    pop-literal infer-quot-value
+    datastack >r >r set-datastack r> execute
-] "infer" set-word-prop
+    datastack r> [ push ] keep set-datastack 2nip ;
 
-\ execute [
+: apply-datastack ( word -- )
-    pop-literal unit infer-quot-value
+    meta-d [ swap with-datastack ] change ;
-] "infer" set-word-prop
 
-! These hacks will go away soon
+: infer-shuffle ( word -- )
-\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
+    dup #call [
-\ no-method t "terminator" set-word-prop
+        over "infer-effect" word-prop
-\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
+        [ apply-datastack ] hairy-node
-\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
+    ] keep node, ;
-\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
-\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
-\ not-a-number t "terminator" set-word-prop
-\ inference-error t "terminator" set-word-prop
-\ throw t "terminator" set-word-prop
-\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
-\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
-\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
-\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop

library/kernel.factor

@@ -3,6 +3,25 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
+: 2drop ( x x -- ) drop drop ; inline
+: 3drop ( x x x -- ) drop drop drop ; inline
+: 2dup ( x y -- x y x y ) over over ; inline
+: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
+: rot ( x y z -- y z x ) >r swap r> swap ; inline
+: -rot ( x y z -- z x y ) swap >r swap r> ; inline
+: dupd ( x y -- x x y ) >r dup r> ; inline
+: swapd ( x y z -- y x z ) >r swap r> ; inline
+: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
+: nip ( x y -- y ) swap drop ; inline
+: 2nip ( x y z -- z ) >r drop drop r> ; inline
+: tuck ( x y -- y x y ) dup >r swap r> ; inline
+
+: clear ( -- )
+    #! Clear the datastack. For interactive use only; invoking
+    #! this from a word definition will clobber any values left
+    #! on the data stack by the caller.
+    { } set-datastack ;
+
 UNION: boolean POSTPONE: f POSTPONE: t ;
 COMPLEMENT: general-t f
 
@@ -28,7 +47,7 @@ M: object clone ;
     rot [ drop ] [ nip ] ifte ; inline
 
 DEFER: wrapper?
-BUILTIN: wrapper 14 wrapper? { 1 "wrapped" "set-wrapped" } ;
+BUILTIN: wrapper 14 wrapper? { 1 "wrapped" f } ;
 
 M: wrapper = ( obj wrapper -- ? )
     over wrapper? [ swap wrapped = ] [ 2drop f ] ifte ;
@@ -56,3 +75,67 @@ DEFER: t?
 : bignum-tag  BIN: 001 ; inline
 : cons-tag    BIN: 010 ; inline
 : object-tag  BIN: 011 ; inline
+
+: slip ( quot x -- x | quot: -- )
+    >r call r> ; inline
+
+: 2slip ( quot x y -- x y | quot: -- )
+    >r >r call r> r> ; inline
+
+: keep ( x quot -- x | quot: x -- )
+    over >r call r> ; inline
+
+: 2keep ( x y quot -- x y | quot: x y -- )
+    over >r pick >r call r> r> ; inline
+
+: 3keep ( x y z quot -- x y z | quot: x y z -- )
+    >r 3dup r> swap >r swap >r swap >r call r> r> r> ; inline
+
+: while ( quot generator -- )
+    #! Keep applying the quotation to the value produced by
+    #! calling the generator until the generator returns f.
+    2dup >r >r swap >r call dup [
+        r> call r> r> while
+    ] [
+        r> 2drop r> r> 2drop
+    ] ifte ; inline
+
+: ifte* ( cond true false -- | true: cond -- | false: -- )
+    #! [ X ] [ Y ] ifte* ==> dup [ X ] [ drop Y ] ifte
+    pick [ drop call ] [ 2nip call ] ifte ; inline
+
+: ?ifte ( default cond true false -- )
+    #! [ X ] [ Y ] ?ifte ==> dup [ nip X ] [ drop Y ] ifte
+    >r >r dup [
+        nip r> r> drop call
+    ] [
+        drop r> drop r> call
+    ] ifte ; inline
+
+: unless ( cond quot -- | quot: -- )
+    #! Execute a quotation only when the condition is f. The
+    #! condition is popped off the stack.
+    [ ] swap ifte ; inline
+
+: unless* ( cond quot -- | quot: -- )
+    #! If cond is f, pop it off the stack and evaluate the
+    #! quotation. Otherwise, leave cond on the stack.
+    over [ drop ] [ nip call ] ifte ; inline
+
+: when ( cond quot -- | quot: -- )
+    #! Execute a quotation only when the condition is not f. The
+    #! condition is popped off the stack.
+    [ ] ifte ; inline
+
+: when* ( cond quot -- | quot: cond -- )
+    #! If the condition is true, it is left on the stack, and
+    #! the quotation is evaluated. Otherwise, the condition is
+    #! popped off the stack.
+    dupd [ drop ] ifte ; inline
+
+: with ( obj quot elt -- obj quot )
+    #! Utility word for each-with, map-with.
+    pick pick >r >r swap call r> r> ; inline
+
+: keep-datastack ( quot -- )
+    datastack slip set-datastack drop ;

library/stack.factor

@@ -1,22 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: kernel
-
-: 2drop ( x x -- ) drop drop ; inline
-: 3drop ( x x x -- ) drop drop drop ; inline
-: 2dup ( x y -- x y x y ) over over ; inline
-: 3dup ( x y z -- x y z x y z ) pick pick pick ; inline
-: rot ( x y z -- y z x ) >r swap r> swap ; inline
-: -rot ( x y z -- z x y ) swap >r swap r> ; inline
-: dupd ( x y -- x x y ) >r dup r> ; inline
-: swapd ( x y z -- y x z ) >r swap r> ; inline
-: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
-: nip ( x y -- y ) swap drop ; inline
-: 2nip ( x y z -- z ) >r drop drop r> ; inline
-: tuck ( x y -- y x y ) dup >r swap r> ; inline
-
-: clear ( -- )
-    #! Clear the datastack. For interactive use only; invoking
-    #! this from a word definition will clobber any values left
-    #! on the data stack by the caller.
-    { } set-datastack ;

library/syntax/prettyprint.factor

@@ -44,15 +44,18 @@ M: word prettyprint* ( indent word -- indent )
 : prettyprint-limit? ( indent -- ? )
     prettyprint-limit get dup [ >= ] [ nip ] ifte ;
 
-: check-recursion ( indent obj quot -- ? indent )
+: check-recursion ( indent obj quot -- indent )
     #! We detect circular structure.
-    pick prettyprint-limit? >r
+    pick prettyprint-limit? [
-    over recursion-check get memq? r> or [
+        2drop "#" write
-        2drop "..." write
     ] [
-        over recursion-check [ cons ] change
+        over recursion-check get memq? [
-        call
+            2drop "&" write
-        recursion-check [ cdr ] change
+        ] [
+            over recursion-check [ cons ] change
+            call
+            recursion-check [ cdr ] change
+        ] ifte
     ] ifte ; inline
 
 : prettyprint-elements ( indent list -- indent )

library/test/compiler/optimizer.factor

@@ -30,11 +30,11 @@ USE: sequences
 
 : foo 1 2 3 ;
 
-[ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test
+[ { } ] [ \ foo word-def dataflow kill-set ] unit-test
 
-[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
+[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
 
-[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
+[ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
 
 [ [ t t f ] ] [
     [ 1 2 3 ] [ <literal> ] map
@@ -53,7 +53,7 @@ USE: sequences
 
 [ 3 ] [ literal-kill-test-3 ] unit-test
 
-[ [ [ 3 ] [ dup ] ] ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
+[ { [ 3 ] [ dup ] } ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
 
 : literal-kill-test-4
     5 swap [ 3 ] [ dup ] ifte 2drop ; compiled
@@ -61,7 +61,7 @@ USE: sequences
 [ ] [ t literal-kill-test-4 ] unit-test
 [ ] [ f literal-kill-test-4 ] unit-test
 
-[ [ [ 3 ] [ dup ] ] ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test
+[ { [ 3 ] [ dup ] } ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test
 
 : literal-kill-test-5
     5 swap [ 5 ] [ dup ] ifte 2drop ; compiled
@@ -69,7 +69,7 @@ USE: sequences
 [ ] [ t literal-kill-test-5 ] unit-test
 [ ] [ f literal-kill-test-5 ] unit-test
 
-[ [ [ 5 ] [ dup ] ] ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test
+[ { [ 5 ] [ dup ] } ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test
 
 : literal-kill-test-6
     5 swap [ dup ] [ dup ] ifte 2drop ; compiled
@@ -77,7 +77,7 @@ USE: sequences
 [ ] [ t literal-kill-test-6 ] unit-test
 [ ] [ f literal-kill-test-6 ] unit-test
 
-[ [ 5 [ dup ] [ dup ] ] ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test
+[ { 5 [ dup ] [ dup ] } ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test
 
 : literal-kill-test-7
     [ 1 2 3 ] >r + r> drop ; compiled

library/test/hashtables.factor

@@ -63,7 +63,7 @@ f 100000000000000000000000000 "testhash" get set-hash
 [ 4 ] [
     "hey"
     {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode)
-    >r buckets>list r> [ cdr ] times car assoc
+    swap buckets>vector nth assoc
 ] unit-test
 
 ! Testing the hash element counting

library/test/sequences.factor

@@ -61,10 +61,6 @@ unit-test
 
 [ "" ] [ { } "" join ] unit-test
 
-[ { "three" "three" "two" "two" "one" "one" } ]
-[ { "one" "two" "three" } { 1 2 3 } { 3 3 2 2 1 1 } subst ]
-unit-test
-
 [ { 1 2 }   ] [ 1 2   2vector ] unit-test
 [ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test
 

library/test/tuple.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: generic kernel test math parser ;
+USING: errors generic kernel math parser sequences test ;
 
 TUPLE: rect x y w h ;
 C: rect
@@ -87,3 +87,6 @@ TUPLE: delegate-clone ;
 [ f ] [ \ object \ delegate-clone class< ] unit-test
 [ t ] [ \ delegate-clone \ tuple class< ] unit-test
 [ f ] [ \ tuple \ delegate-clone class< ] unit-test
+
+! Compiler regression
+[ t ] [ [ t length ] [ no-method-object ] catch ] unit-test