working on the compiler

library/bootstrap/boot-stage2.factor

@@ -28,12 +28,14 @@ recrossref
 t [
     "/library/inference/conditions.factor"
     "/library/inference/dataflow.factor"
+    "/library/inference/values.factor"
     "/library/inference/inference.factor"
     "/library/inference/ties.factor"
     "/library/inference/branches.factor"
     "/library/inference/words.factor"
     "/library/inference/stack.factor"
     "/library/inference/types.factor"
+    "/library/inference/partial-eval.factor"
 
     "/library/compiler/assembler.factor"
     "/library/compiler/relocate.factor"

library/bootstrap/boot-stage3.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-USING: alien assembler command-line compiler io-internals kernel
+USING: alien assembler command-line compiler compiler-backend
-lists math namespaces parser sequences stdio unparser words ;
+io-internals kernel lists math namespaces parser sequences stdio
+unparser words ;
 
 "Compiling base..." print
 
@@ -36,6 +37,7 @@ compile? [
     \ = compile
     \ unparse compile
     \ scan compile
+    \ (generate) compile
 ] when
 
 "Loading more library code..." print

library/collections/sequences-epilogue.factor

@@ -182,7 +182,7 @@ C: range ( from to -- range )
     [ set-range-from ] keep ;
 
 M: range length ( range -- n )
-    dup range-to swap range-from - abs 1 + ;
+    dup range-to swap range-from - abs ;
 
 M: range nth ( n range -- n )
     [ range-step * ] keep range-from + ;
@@ -200,6 +200,9 @@ M: slice nth ( n slice -- obj )
 M: slice set-nth ( obj n slice -- )
     [ delegate nth ] keep slice-seq set-nth ;
 
+: tail-slice ( n seq -- slice )
+    [ length [ swap - ] keep ] keep <slice> ;
+
 IN: kernel
 
 : depth ( -- n )

library/compiler/intrinsics.factor

@@ -11,18 +11,20 @@ sequences words ;
     #! by GC, and is indexed through a table.
     dup fixnum? swap f eq? or ;
 
+: push-1 ( obj -- )
+    0 swap literal-value dup
+    immediate? [ %immediate ] [ %indirect ] ifte , ;
+
 #push [
-    1 %inc-d ,
+    [ node-produce-d get ] bind
-    [ node-param get ] bind dup immediate? [
+    dup length dup %inc-d ,
-        %immediate-d ,
+    1 - swap [
-    ] [
+        push-1 0 over %replace-d ,
-        0 swap %indirect ,  out-1
+    ] each drop
-    ] ifte
 ] "linearizer" set-word-prop
 
-\ drop [
+#drop [
-    drop
+    [ node-consume-d get length ] bind %dec-d ,
-    1 %dec-d ,
 ] "linearizer" set-word-prop
 
 \ dup [
@@ -171,9 +173,12 @@ sequences words ;
     1 <vreg> 0 <vreg> rot execute ,
     r> 0 %replace-d , ;
 
+: literal-fixnum? ( value -- ? )
+    dup literal? [ literal-value fixnum? ] [ drop f ] ifte ;
+
 : binary-op ( node op out -- )
     #! out is a vreg where the vop stores the result.
-    >r >r node-peek dup literal? [
+    >r >r node-peek dup literal-fixnum? [
         1 %dec-d ,
         in-1
         literal-value 0 <vreg> r> execute ,
@@ -206,7 +211,7 @@ sequences words ;
 
 \ fixnum* [
     ! Turn multiplication by a power of two into a left shift.
-    node-peek dup literal? [
+    node-peek dup literal-fixnum? [
         literal-value dup power-of-2? [
             1 %dec-d ,
             in-1

library/compiler/linearizer.factor

@@ -21,16 +21,6 @@ math namespaces words strings errors prettyprint sequences ;
     #! rest is arguments.
     [ %prologue , (linearize) ] make-list ;
 
-: linearize-simple-label ( node -- )
-    #! Some labels become simple labels after the optimization
-    #! stage.
-    dup [ node-label get ] bind %label ,
-    [ node-param get ] bind (linearize) ;
-
-#simple-label [
-    linearize-simple-label
-] "linearizer" set-word-prop
-
 : linearize-label ( node -- )
     #! Labels are tricky, because they might contain non-tail
     #! calls. So we push the address of the location right after
@@ -39,7 +29,8 @@ math namespaces words strings errors prettyprint sequences ;
     #! this in the common case where the labelled block does
     #! not contain non-tail recursive calls to itself.
     <label> dup %return-to , >r
-    linearize-simple-label
+    dup [ node-label get ] bind %label ,
+    [ node-param get ] bind (linearize)
     f %return ,
     r> %label , ;
 

library/compiler/optimizer.factor

@@ -100,9 +100,26 @@ SYMBOL: branch-returns
         node-param [ [ dupd kill-nodes ] map nip ] change
     ] extend , ;
 
-#push [ [ node-param get ] bind , ] "scan-literal" set-word-prop
+: kill-literal ( literals values -- values )
-#push [ consumes-literal? not ] "can-kill" set-word-prop
+    [
-#push [ kill-node ] "kill-node" set-word-prop
+        swap [ swap value= ] some-with? not
+    ] subset-with ;
+
+#push [
+    [ node-produce-d get ] bind [ literal-value ] map %
+] "scan-literal" set-word-prop
+
+#push [ 2drop t ] "can-kill" set-word-prop
+
+#push [
+    [ node-produce-d [ kill-literal ] change ] extend ,
+] "kill-node" set-word-prop
+
+#drop [ 2drop t ] "can-kill" set-word-prop
+
+#drop [
+    [ node-consume-d [ kill-literal ] change ] extend ,
+] "kill-node" set-word-prop
 
 #label [
     [ node-param get ] bind (scan-literals)
@@ -123,10 +140,6 @@ SYMBOL: branch-returns
     [ node-param get ] bind calls-label?
 ] "calls-label" set-word-prop
 
-#simple-label [
-    [ node-param get ] bind calls-label?
-] "calls-label" set-word-prop
-
 : branches-call-label? ( label list -- ? )
     [ calls-label? ] some-with? ;
 
@@ -138,16 +151,8 @@ SYMBOL: branch-returns
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-prop
 
-: optimize-label ( -- op )
-    #! Does the label node contain calls to itself?
-    node-label get node-param get calls-label?
-    #label #simple-label ? ;
-
 #label [ ( literals node -- )
-    [
+    [ node-param [ kill-nodes ] change ] extend ,
-        optimize-label node-op set
-        node-param [ kill-nodes ] change
-    ] extend ,
 ] "kill-node" set-word-prop
 
 #values [

library/compiler/simplifier.factor

@@ -51,14 +51,15 @@ M: %label simplify-node ( linear vop -- linear ? )
 
 M: %inc-d simplify-node ( linear vop -- linear ? )
     #! %inc-d cancels a following %inc-d.
-    >r dup \ %inc-d next-physical? [
+    dup vop-literal 0 = [
-        vop-literal r> vop-literal + dup 0 = [
+        drop cdr t
-            drop cdr cdr f
-        ] [
-            %inc-d >r cdr cdr r> swons t
-        ] ifte
     ] [
-        r> 2drop f
+        >r dup \ %inc-d next-physical? [
+            vop-literal r> vop-literal + 
+            %inc-d >r cdr cdr r> swons t
+        ] [
+            r> 2drop f
+        ] ifte
     ] ifte ;
 
 : dead-load? ( linear vop -- ? )
@@ -91,8 +92,8 @@ M: %replace-d simplify-node ( linear vop -- linear ? )
         ] ifte
     ] ifte ;
 
-M: %immediate-d simplify-node ( linear vop -- linear ? )
+! M: %immediate-d simplify-node ( linear vop -- linear ? )
-    over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
+!     over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
 
 : pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
 

library/compiler/vops.factor

@@ -93,8 +93,8 @@ VOP: %inc-d
 : %inc-d ( n -- ) literal-vop <%inc-d> ;
 : %dec-d ( n -- ) neg %inc-d ;
 VOP: %immediate
-VOP: %immediate-d
+: %immediate ( vreg obj -- )
-: %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
+    >r <vreg> r> dest/literal-vop <%immediate> ;
 VOP: %peek-r
 : %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
 VOP: %replace-r

library/compiler/x86/fixnum.factor

@@ -36,7 +36,7 @@ memory namespaces words ;
     ! An untagged pointer to the bignum is now in EAX; tag it
     EAX bignum-tag OR
     ESP 4 ADD
-    "end" get save-xt ;
+    "end" get save-xt ; inline
 
 M: %fixnum+ generate-node ( vop -- )
     dest/src 2dup ADD  \ SUB \ ADD simple-overflow ;

library/compiler/x86/stack.factor

@@ -30,9 +30,6 @@ M: %inc-d generate-node ( vop -- )
 M: %immediate generate-node ( vop -- )
     dup vop-dest v>operand swap vop-literal address MOV ;
 
-M: %immediate-d generate-node ( vop -- )
-    vop-literal [ ESI ] swap address MOV ;
-
 : load-indirect ( dest literal -- )
     intern-literal unit MOV 0 0 rel-address ;
 

library/generic/builtin.factor

@@ -39,7 +39,7 @@ builtin [ 2drop t ] "class<" set-word-prop
     dup intern-symbol
     dup r> "builtin-type" set-word-prop
     dup builtin define-class
-    dup r> unit "predicate" set-word-prop
+    dup r> set-predicate
     dup builtin-predicate
     dup r> define-slots
     register-builtin ;

library/generic/generic.factor

@@ -174,4 +174,8 @@ SYMBOL: object
     dup builtin-supertypes [ > ] sort
     typemap get set-hash ;
 
+: set-predicate ( class word -- )
+    dup t "inline" set-word-prop
+    unit "predicate" set-word-prop ;
+
 typemap get [ <namespace> typemap set ] unless

library/generic/tuple.factor

@@ -69,8 +69,7 @@ UNION: arrayed array tuple ;
 : tuple-predicate ( word -- )
     #! Make a foo? word for testing the tuple class at the top
     #! of the stack.
-    dup predicate-word
+    dup predicate-word 2dup set-predicate
-    2dup unit "predicate" set-word-prop
     swap [
         [ dup tuple? ] %
         [ \ class-tuple , literal, \ eq? , ] make-list ,
@@ -78,12 +77,15 @@ UNION: arrayed array tuple ;
         \ ifte ,
     ] make-list define-compound ;
 
+: forget-tuple ( class -- )
+    dup forget "predicate" word-prop car forget ;
+
 : check-shape ( word slots -- )
     #! If the new list of slots is different from the previous,
     #! forget the old definition.
     >r "use" get search dup [
         dup "tuple-size" word-prop r> length 2 + =
-        [ drop ] [ forget ] ifte
+        [ drop ] [ forget-tuple ] ifte
     ] [
         r> 2drop
     ] ifte ;

library/inference/branches.factor

@@ -4,7 +4,7 @@ IN: inference
 USING: errors generic interpreter kernel lists math namespaces
 sequences strings vectors words hashtables prettyprint ;
 
-: longest-vector ( list -- length )
+: longest ( list -- length )
     0 swap [ length max ] each ;
 
 : computed-value-vector ( n -- vector )
@@ -17,7 +17,7 @@ sequences strings vectors words hashtables prettyprint ;
 : unify-lengths ( list -- list )
     #! Pad all vectors to the same length. If one vector is
     #! shorter, pad it with unknown results at the bottom.
-    dup longest-vector swap [ add-inputs ] map-with ;
+    dup longest swap [ add-inputs ] map-with ;
 
 : unify-results ( list -- value )
     #! If all values in list are equal, return the value.
@@ -137,49 +137,20 @@ SYMBOL: cloned
     #! base case to this stack effect and try again.
     (infer-branches) dup unify-effects unify-dataflow ;
 
-: (with-block) ( [[ label quot ]] quot -- node )
+: infer-ifte ( true false -- )
-    #! Call a quotation in a new namespace, and transfer
-    #! inference state from the outer scope.
-    swap car >r [
-        dataflow-graph off
-        call
-        d-in get meta-d get meta-r get get-dataflow
-    ] with-scope
-    r> swap #label dataflow, [ node-label set ] extend >r
-    meta-r set meta-d set d-in set r> ;
-
-: with-block ( word [[ label quot ]] quot -- node )
-    #! Execute a quotation with the word on the stack, and add
-    #! its dataflow contribution to a new block node in the IR.
-    over [
-        >r
-        dupd cons
-        recursive-state [ cons ] change
-        r> call
-    ] (with-block) ;
-
-: dynamic-ifte ( true false -- )
     #! If branch taken is computed, infer along both paths and
     #! unify.
-    2list >r peek-d \ ifte r>
+    2list >r pop-d \ ifte r>
-    pop-d [
+    pick [ general-t POSTPONE: f ] [ <class-tie> ] map-with
-        dup \ general-t <class-tie> ,
+    zip ( condition )
-        \ f <class-tie> ,
-    ] make-list zip ( condition )
     infer-branches ;
 
-: infer-ifte ( -- )
+\ ifte [
-    #! Infer effects for both branches, unify.
+    2 dataflow-drop, pop-d pop-d swap infer-ifte
-    [ object general-list general-list ] ensure-d
+] "infer" set-word-prop
-    dataflow-drop, pop-d
-    dataflow-drop, pop-d swap
-    dynamic-ifte ;
 
-\ ifte [ infer-ifte ] "infer" set-word-prop
+: vtable>list ( rstate vtable -- list  )
-
+    [ swap <literal> ] map-with >list ;
-: vtable>list ( value -- list )
-    dup value-recursion swap literal-value >list
-    [ over <literal> ] map nip ;
 
 : <dispatch-index> ( value -- value )
     value-literal-ties
@@ -188,17 +159,12 @@ SYMBOL: cloned
 
 USE: kernel-internals
 
-: dynamic-dispatch ( vtable -- )
+: infer-dispatch ( rstate vtable -- )
-    >r peek-d \ dispatch r>
+    >r >r peek-d \ dispatch r> r>
     vtable>list
     pop-d <dispatch-index>
     over length [ <literal-tie> ] project-with
     zip infer-branches ;
 
-: infer-dispatch ( -- )
+\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
-    #! Infer effects for all branches, unify.
-    [ object vector ] ensure-d
-    dataflow-drop, pop-d dynamic-dispatch ;
-
-\ dispatch [ infer-dispatch ] "infer" set-word-prop
 \ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

library/inference/dataflow.factor

@@ -1,39 +1,11 @@
-! :folding=indent:collapseFolds=1:
+! Copyright (C) 2004, 2005 Slava Pestov.
-
+! See http://factor.sf.net/license.txt for BSD license.
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
 IN: inference
-USE: interpreter
+USING: interpreter kernel lists namespaces sequences vectors
-USE: kernel
+words ;
-USE: lists
+
-USE: math
+! Recursive state. An alist, mapping words to labels.
-USE: namespaces
+SYMBOL: recursive-state
-USE: words
-USE: vectors
-USE: sequences
 
 ! We build a dataflow graph for the compiler.
 SYMBOL: dataflow-graph
@@ -41,14 +13,10 @@ SYMBOL: dataflow-graph
 ! Label nodes have the node-label variable set.
 SYMBOL: #label
 
-! A label that is not called recursively at all, or only tail
-! recursively. The optimizer changes some #labels to
-! #simple-labels.
-SYMBOL: #simple-label
-
 SYMBOL: #call ( non-tail call )
 SYMBOL: #call-label
 SYMBOL: #push ( literal )
+SYMBOL: #drop
 
 ! This is purely a marker for values we retain after a
 ! conditional. It does not generate code, but merely alerts the
@@ -101,10 +69,11 @@ SYMBOL: node-param
     #! Add a node to the dataflow IR.
     <dataflow-node> dup dataflow-graph [ cons ] change ;
 
-: dataflow-drop, ( -- )
+: dataflow-drop, ( n -- )
-    #! Remove the top stack element and add a dataflow node
+    f #drop dataflow, [ 0 node-inputs ] bind ;
-    #! noting this.
+
-    f \ drop dataflow, [ 1 0 node-inputs ] bind ;
+: dataflow-push, ( n -- )
+    f #push dataflow, [ 0 node-outputs ] bind ;
 
 : apply-dataflow ( dataflow name default -- )
     #! For the dataflow node, look up named word property,

library/inference/inference.factor

@@ -17,68 +17,9 @@ SYMBOL: inferring-base-case
 ! inputs.
 SYMBOL: d-in
 
-! Recursive state. An alist, mapping words to labels.
-SYMBOL: recursive-state
-
-GENERIC: value= ( literal value -- ? )
-GENERIC: value-class-and ( class value -- )
-
-TUPLE: value class recursion class-ties literal-ties ;
-
-C: value ( recursion -- value )
-    [ set-value-recursion ] keep ;
-
-TUPLE: computed ;
-
-C: computed ( class -- value )
-    swap recursive-state get <value> [ set-value-class ] keep
-    over set-delegate ;
-
-M: computed value= ( literal value -- ? )
-    2drop f ;
-
-: failing-class-and ( class class -- class )
-    2dup class-and dup null = [
-        -rot [
-            word-name , " and " , word-name ,
-            " do not intersect" ,
-        ] make-string inference-warning
-    ] [
-        2nip
-    ] ifte ;
-
-M: computed value-class-and ( class value -- )
-    [
-        value-class  failing-class-and
-    ] keep set-value-class ;
-
-TUPLE: literal value ;
-
-C: literal ( obj rstate -- value )
-    [
-        >r <value> [ >r dup class r> set-value-class ] keep
-        r> set-delegate
-    ] keep
-    [ set-literal-value ] keep ;
-
-M: literal value= ( literal value -- ? )
-    literal-value = ;
-
-M: literal value-class-and ( class value -- )
-    value-class class-and drop ;
-
-M: literal set-value-class ( class value -- )
-    2drop ;
-
-M: computed literal-value ( value -- )
-    "A literal value was expected where a computed value was"
-    " found: " rot unparse cat3 inference-error ;
-
-: value-types ( value -- list )
-    value-class builtin-supertypes ;
-
 : pop-literal ( -- rstate obj )
-    dataflow-drop, pop-d dup value-recursion swap literal-value ;
+    1 dataflow-drop, pop-d
+    dup value-recursion swap literal-value ;
 
 : (ensure-types) ( typelist n stack -- )
     pick [
@@ -131,8 +72,7 @@ GENERIC: apply-object
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    dup recursive-state get <literal> push-d
+    recursive-state get <literal> push-d  1 dataflow-push, ;
-    #push dataflow, [ 1 0 node-outputs ] bind ;
 
 M: object apply-object apply-literal ;
 
@@ -140,11 +80,6 @@ M: object apply-object apply-literal ;
     #! Is this branch not terminated?
     d-in get meta-d get and ;
 
-: check-active ( -- )
-    active? [
-         "Provable runtime error" inference-error
-    ] unless ;
-
 : effect ( -- [[ d-in meta-d ]] )
     d-in get meta-d get cons ;
 
@@ -170,9 +105,12 @@ M: object apply-object apply-literal ;
         drop
     ] ifte ;
 
+: check-active ( -- )
+    active? [ "Provable runtime error" inference-error ] unless ;
+
 : check-return ( -- )
     #! Raise an error if word leaves values on return stack.
-    meta-r get length 0 = [
+    meta-r get empty? [
         "Word leaves elements on return stack" inference-error
     ] unless ;
 
@@ -182,16 +120,18 @@ M: object apply-object apply-literal ;
         meta-d get >list node-consume-d set
     ] bind ;
 
-: (infer) ( quot -- )
+: with-infer ( quot -- )
-    f init-inference
+    [
-    infer-quot
+        f init-inference
-    check-active
+        call
-    #return values-node check-return ;
+        check-active
+        check-return
+    ] with-scope ;
 
 : infer ( quot -- [[ in out ]] )
     #! Stack effect of a quotation.
-    [ (infer) effect present-effect ] with-scope ;
+    [ infer-quot effect present-effect ] with-infer ;
 
 : dataflow ( quot -- dataflow )
     #! Data flow of a quotation.
-    [ (infer) get-dataflow ] with-scope ;
+    [ infer-quot #return values-node get-dataflow ] with-infer ;

library/inference/partial-eval.factor

@@ -0,0 +1,96 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: generic interpreter kernel lists math namespaces
+sequences words ;
+
+: literal-inputs? ( in stack -- )
+    tail-slice dup >list [ literal-safe? ] all? [
+        length dataflow-drop, t
+    ] [
+        drop f
+    ] ifte ;
+
+: literal-inputs ( out stack -- )
+    tail-slice [ literal-value ] nmap ;
+
+: literal-outputs ( out stack -- )
+    tail-slice dup [ recursive-state get <literal> ] nmap
+    length dataflow-push, ;
+
+: partial-eval? ( word -- ? )
+    "infer-effect" word-prop car length
+    meta-d get literal-inputs? ;
+
+: infer-eval ( word -- )
+    dup partial-eval? [
+        dup "infer-effect" word-prop 2unlist
+        >r length meta-d get
+        literal-inputs
+        host-word
+        r> length meta-d get literal-outputs
+    ] [
+        dup "infer-effect" word-prop consume/produce
+    ] ifte ;
+
+: stateless ( word -- )
+    #! A stateless word can be evaluated at compile-time.
+    dup unit [ car infer-eval ] cons "infer" set-word-prop ;
+
+! Could probably add more words here
+[
+    car
+    cdr
+    cons
+    <
+    <=
+    >
+    >=
+    number=
+    +
+    -
+    *
+    /
+    /i
+    /f
+    mod
+    /mod
+    bitand
+    bitor
+    bitxor
+    shift
+    bitnot
+    >fixnum
+    >bignum
+    >float
+    real
+    imaginary
+] [
+    stateless
+] each
+
+! Partially-evaluated words need their stack effects to be
+! entered by hand.
+\ 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= [ [ real real ] [ 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
+\ gcd [ [ integer integer ] [ 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/stack.factor

@@ -15,12 +15,13 @@ USING: interpreter kernel namespaces words ;
     [ 1 0 node-outputs ] bind
 ] "infer" set-word-prop
 
-: infer-shuffle ( word -- )
+: partial-eval ( word quot -- | quot: word -- )
-    f over dup
+    >r f over dup "infer-effect" word-prop r> with-dataflow ;
-    "infer-effect" word-prop
-    [ host-word ] with-dataflow ;
 
-\ drop [ \ drop infer-shuffle ] "infer" set-word-prop
+: infer-shuffle ( word -- )
+    [ host-word ] partial-eval ;
+
+\ drop [ 1 dataflow-drop, 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

library/inference/values.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: generic kernel namespaces sequences unparser words ;
+
+GENERIC: value= ( literal value -- ? )
+GENERIC: value-class-and ( class value -- )
+
+TUPLE: value class recursion class-ties literal-ties ;
+
+C: value ( recursion -- value )
+    [ set-value-recursion ] keep ;
+
+TUPLE: computed ;
+
+C: computed ( class -- value )
+    swap recursive-state get <value> [ set-value-class ] keep
+    over set-delegate ;
+
+M: computed value= ( literal value -- ? )
+    2drop f ;
+
+: failing-class-and ( class class -- class )
+    2dup class-and dup null = [
+        -rot [
+            word-name , " and " , word-name ,
+            " do not intersect" ,
+        ] make-string inference-warning
+    ] [
+        2nip
+    ] ifte ;
+
+M: computed value-class-and ( class value -- )
+    [
+        value-class  failing-class-and
+    ] keep set-value-class ;
+
+TUPLE: literal value safe? ;
+
+C: literal ( obj rstate -- value )
+    [ t swap set-literal-safe? ] keep
+    [
+        >r <value> [ >r dup class r> set-value-class ] keep
+        r> set-delegate
+    ] keep
+    [ set-literal-value ] keep ;
+
+M: literal value= ( literal value -- ? )
+    literal-value = ;
+
+M: literal value-class-and ( class value -- )
+    value-class class-and drop ;
+
+M: literal set-value-class ( class value -- )
+    2drop ;
+
+M: computed literal-safe? drop f ;
+
+M: computed set-literal-safe? 2drop ;
+
+M: computed literal-value ( value -- )
+    "A literal value was expected where a computed value was"
+    " found: " rot unparse append3 inference-error ;
+
+: value-types ( value -- list )
+    value-class builtin-supertypes ;

library/inference/words.factor

@@ -33,13 +33,48 @@ hashtables parser prettyprint ;
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 inference-error ;
 
-: inline-compound ( word -- effect node )
+: inhibit-parital ( -- )
+    meta-d get [ f swap set-literal-safe? ] each ;
+
+: recursive? ( word -- ? )
+    f swap dup word-def [ = or ] tree-each-with ;
+
+: (with-block) ( [[ label quot ]] quot -- node )
+    #! Call a quotation in a new namespace, and transfer
+    #! inference state from the outer scope.
+    swap car >r [
+        dataflow-graph off
+        call
+        d-in get meta-d get meta-r get get-dataflow
+    ] with-scope
+    r> swap #label dataflow, [ node-label set ] extend >r
+    meta-r set meta-d set d-in set r> ;
+
+: with-block ( word [[ label quot ]] quot -- node )
+    #! Execute a quotation with the word on the stack, and add
+    #! its dataflow contribution to a new block node in the IR.
+    over [
+        >r
+        dupd cons
+        recursive-state [ cons ] change
+        r> call
+    ] (with-block) ;
+
+: inline-block ( word -- effect node )
+    gensym over word-def cons [
+        inhibit-parital
+        word-def infer-quot effect
+    ] with-block ;
+
+: inline-compound ( word -- )
     #! Infer the stack effect of a compound word in the current
     #! inferencer instance. If the word in question is recursive
     #! we infer its stack effect inside a new block.
-    gensym over word-def cons [
+    dup recursive? [
-        word-def infer-quot effect
+        inline-block 2drop
-    ] with-block ;
+    ] [
+        word-def infer-quot
+    ] ifte ;
 
 : infer-compound ( word -- )
     #! Infer a word's stack effect in a separate inferencer
@@ -47,7 +82,7 @@ hashtables parser prettyprint ;
     [
         [
             recursive-state get init-inference
-            dup dup inline-compound drop present-effect
+            dup dup inline-block drop present-effect
             [ "infer-effect" set-word-prop ] keep
         ] with-scope consume/produce
     ] [
@@ -66,6 +101,9 @@ M: object (apply-word) ( word -- )
     #! A primitive with an unknown stack effect.
     no-effect ;
 
+M: primitive (apply-word) ( word -- )
+    dup "infer-effect" word-prop consume/produce ;
+
 M: compound (apply-word) ( word -- )
     #! Infer a compound word's stack effect.
     dup "no-effect" word-prop [
@@ -95,7 +133,7 @@ M: word apply-word ( word -- )
 
 M: compound apply-word ( word -- )
     dup "inline" word-prop [
-        inline-compound 2drop
+        inline-compound
     ] [
         apply-default
     ] ifte ;
@@ -111,7 +149,7 @@ M: compound apply-word ( word -- )
 
 : base-case ( word [ label quot ] -- )
     [
-        car over inline-compound [
+        car over inline-block [
             drop
             [ #call-label ] [ #call ] ?ifte
             node-op set
@@ -126,11 +164,15 @@ M: compound apply-word ( word -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    inferring-base-case get [
+    over "infer-effect" word-prop [
-        drop no-base-case
+        nip consume/produce
     ] [
-        base-case
+        inferring-base-case get [
-    ] ifte ;
+            drop no-base-case
+        ] [
+            base-case
+        ] ifte
+    ] ifte* ;
 
 M: word apply-object ( word -- )
     #! Apply the word's stack effect to the inferencer state.
@@ -141,41 +183,28 @@ M: word apply-object ( word -- )
     ] ifte* ;
 
 : infer-quot-value ( rstate quot -- )
-    gensym dup pick cons [
+    recursive-state get >r
-        drop
+    swap recursive-state set
-        swap recursive-state set
+    dup infer-quot handle-terminator
-        dup infer-quot
+    r> recursive-state set ;
-    ] with-block drop handle-terminator ;
 
 \ call [
-    [ general-list ] ensure-d pop-literal infer-quot-value
+    pop-literal infer-quot-value
 ] "infer" set-word-prop
 
 \ execute [
-    [ word ] ensure-d pop-literal unit infer-quot-value
+    pop-literal unit infer-quot-value
 ] "infer" set-word-prop
 
 ! These hacks will go away soon
-\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
-\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ no-method t "terminator" set-word-prop
-\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
+\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
-\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
-\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ <= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
-\ < [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
-\ >= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
-\ > [ [ number number ] [ boolean ] ] "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
-\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
-\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop
-\ 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 word ] [ tuple ] ] "infer-effect" set-word-prop
 \ not-a-number 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

library/math/math.factor

@@ -33,19 +33,18 @@ GENERIC: truncate ( n -- n )
 GENERIC: floor    ( n -- n )
 GENERIC: ceiling  ( n -- n )
 
-: max ( x y -- z ) [ > ] 2keep ? ;
+: max ( x y -- z ) [ > ] 2keep ? ; inline
-
+: min ( x y -- z ) [ < ] 2keep ? ; inline
-: min ( x y -- z ) [ < ] 2keep ? ;
 
 : between? ( x min max -- ? )
     #! Push if min <= x <= max. Handles case where min > max
     #! by swapping them.
     2dup > [ swap ] when  >r dupd max r> min = ;
 
-: sq dup * ;
+: sq dup * ; inline
 
-: neg 0 swap - ;
+: neg 0 swap - ; inline
-: recip 1 swap / ;
+: recip 1 swap / ; inline
 
 : rem ( x y -- x%y )
     #! Like modulus, but always gives a positive result.

library/test/benchmark/prettyprint.factor

@@ -4,6 +4,7 @@ USE: prettyprint
 USE: test
 USE: words
 USE: kernel
+USE: sequences
 
 [ ] [ gensym dup [ ] define-compound . ] unit-test
 [ ] [ vocabs [ words [ see ] each ] each ] unit-test

library/test/compiler/optimizer.factor

@@ -1,5 +1,6 @@
 IN: temporary
 USE: test
+USE: assembler
 USE: compiler
 USE: compiler-frontend
 USE: inference
@@ -13,8 +14,6 @@ USE: sequences
 
 [ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test
 
-[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test
-
 [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
 
 [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
@@ -22,3 +21,15 @@ USE: sequences
 [ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f <literal> ] map kill-mask ] unit-test
 
 [ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test
+
+: literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
+
+[ 4 ] [ literal-kill-test-1 drop ] unit-test
+
+: literal-kill-test-2 3 compiled-offset cell 2 * - ; compiled
+
+[ 3 ] [ literal-kill-test-2 drop ] unit-test
+
+: literal-kill-test-3 10 3 /mod drop ; compiled
+
+[ 3 ] [ literal-kill-test-3 ] unit-test

library/test/dataflow.factor

@@ -19,7 +19,7 @@ sequences test words ;
     ] some-with? ;
 
 [ t ] [
-    \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean
+    \ + [ 2 + ] dataflow dataflow-contains-param? >boolean
 ] unit-test
 
 : inline-test
@@ -79,10 +79,3 @@ SYMBOL: #test
         [[ node-param 5 ]]
     }} "foobar" [ [ node-param get ] bind 1 + ] apply-dataflow
 ] unit-test
-
-! Somebody (cough) got the order of ifte nodes wrong.
-
-[ t ] [
-    \ ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
-    [ node-param get ] bind car car [ node-param get ] bind 1 =
-] unit-test

library/test/gadgets.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: gadgets kernel lists math namespaces test ;
+USING: gadgets kernel lists math namespaces test sequences ;
 
 [ t ] [
     [

library/test/math/bitops.factor

@@ -3,6 +3,7 @@ USE: kernel
 USE: math
 USE: test
 USE: lists
+USE: sequences
 
 [ -2 ] [ 1 bitnot ] unit-test
 [ -2 ] [ 1 >bignum bitnot ] unit-test

library/test/memory.factor

@@ -1,5 +1,6 @@
 IN: temporary
-USING: generic kernel lists math memory words prettyprint test ;
+USING: generic kernel lists math memory words prettyprint 
+sequences test ;
 
 [ ] [
     num-types [

library/test/sequences.factor

@@ -1,8 +1,9 @@
 IN: temporary
-USING: lists test sequences ;
+USING: lists sequences test vectors ;
 
-[ [ 1 2 3 4 ] ] [ 1 4 <range> >list ] unit-test
+[ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
-[ 4 ] [ 1 4 <range> length ] unit-test
+[ 3 ] [ 1 4 <range> length ] unit-test
-[ [ 4 3 2 1 ] ] [ 4 1 <range> >list ] unit-test
+[ [ 4 3 2 1 ] ] [ 4 0 <range> >list ] unit-test
-[ 2 ] [ 1 2 { 1 2 3 4 } <slice> length ] unit-test
+[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
-[ [ 2 3 ] ] [ 1 2 { 1 2 3 4 } <slice> >list ] unit-test
+[ [ 2 3 ] ] [ 1 3 { 1 2 3 4 } <slice> >list ] unit-test
+[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice >vector ] unit-test

library/test/test.factor

@@ -69,7 +69,7 @@ SYMBOL: failures
             "lists/namespaces" "lists/combinators" "combinators"
             "continuations" "errors" "hashtables" "strings"
             "namespaces" "generic" "tuple" "files" "parser"
-            "parse-number" "prettyprint" "image" "init" "io/io"
+            "parse-number" "image" "init" "io/io"
             "listener" "vectors" "words" "unparser" "random"
             "stream" "math/bitops"
             "math/math-combinators" "math/rational" "math/float"
@@ -102,7 +102,7 @@ SYMBOL: failures
             "benchmark/fib" "benchmark/sort"
             "benchmark/continuations" "benchmark/ack"
             "benchmark/hashtables" "benchmark/strings"
-            "benchmark/vectors"
+            "benchmark/vectors" "benchmark/prettyprint"
         ] %
     ] make-list ;
 

library/test/tuple.factor

@@ -41,13 +41,16 @@ C: quuux-tuple-2
 [
     100
 ] [
+    FORGET: point
+    FORGET: point?
+    FORGET: point-x
     TUPLE: point x y ;
     C: point [ set-point-y ] keep [ set-point-x ] keep ;
     
     100 200 <point>
     
     ! Use eval to sequence parsing explicitly
-    "TUPLE: point x y z ;" eval
+    "IN: temporary TUPLE: point x y z ;" eval
     
     point-x
 ] unit-test

library/test/words.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: generic kernel lists math namespaces test words ;
+USING: generic kernel lists math namespaces test words sequences ;
 
 [ 4 ] [
     "poo" "scratchpad" create [ 2 2 + ] define-compound

library/tools/memory.factor

@@ -109,7 +109,7 @@ M: object (each-slot) ( quot obj -- )
 : orphan? ( word -- ? )
     #! Test if the word is not a member of its vocabulary.
     dup dup word-name swap word-vocabulary dup [
-        vocab hash eq? not
+        vocab dup [ hash eq? not ] [ 3drop t ] ifte
     ] [
         3drop t
     ] ifte ;

library/vocabularies.factor

@@ -37,7 +37,7 @@ SYMBOL: vocabularies
 
 : recrossref ( -- )
     #! Update word cross referencing information.
-    [ f "usages" set-word-prop ] each-word
+    global [ <namespace> crossref set ] bind
     [ add-crossref ] each-word ;
 
 : (search) ( name vocab -- word )