starting to update simplifier for vops

TODO.FACTOR.txt

@@ -25,11 +25,12 @@
 - dipping seq-2nmap, seq-2each
 - array sort
 - tiled window manager
-- PPC #box-float #unbox-float
+- redo new compiler backend for PowerPC
 - weird bug uncovered during bootstrap stress-test
 - images saved from plugin do not work
 - making an image from plugin hangs
 - generic skip
+- inference needs to be more robust with heavily recursive code
 
 + plugin:
 

library/alien/c-types.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler errors generic hashtables kernel lists
+USING: assembler compiler compiler-backend errors generic
-math namespaces parser sequences strings words ;
+hashtables kernel lists math namespaces parser sequences strings
+words ;
 
 : <c-type> ( -- type )
     <namespace> [

library/alien/compiler.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler errors generic inference kernel lists
+USING: assembler compiler compiler-backend errors generic
-math namespaces sequences stdio strings unparser words ;
+inference kernel lists math namespaces sequences stdio strings
+unparser words ;
 
 ! ! ! WARNING ! ! !
 ! Reloading this file into a running Factor instance on Win32

library/bootstrap/boot-stage3.factor

@@ -1,7 +1,7 @@
 ! 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
-lists namespaces parser sequences stdio unparser words ;
+lists math namespaces parser sequences stdio unparser words ;
 
 "Compiling base..." print
 
@@ -31,6 +31,7 @@ init-assembler
 
 compile? [
     \ car compile
+    \ * compile
     \ length compile
     \ = compile
     \ unparse compile

library/compiler/compiler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 IN: compiler
-USING: errors inference kernel lists namespaces prettyprint
+USING: compiler-backend compiler-frontend errors inference
-stdio words ;
+kernel lists namespaces prettyprint stdio words ;
 
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;

library/compiler/generator.factor

@@ -1,8 +1,11 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: assembler errors inference kernel lists math namespaces
+USING: assembler compiler errors inference kernel lists math
-sequences strings vectors words ;
+namespaces sequences strings vectors words ;
+
+! Compile a VOP.
+GENERIC: generate-node ( vop -- )
 
 : generate-code ( word linear -- length )
     compiled-offset >r

library/compiler/intrinsics.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-frontend
-USING: assembler generic hashtables inference kernel
+USING: assembler compiler-backend generic hashtables inference
-kernel-internals lists math math-internals namespaces sequences
+kernel kernel-internals lists math math-internals namespaces
-words ;
+sequences words ;
 
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
@@ -171,6 +171,7 @@ words ;
     [[ fixnum<       %fixnum<       ]]
     [[ fixnum>=      %fixnum>=      ]]
     [[ fixnum>       %fixnum>       ]]
+    [[ eq?           %eq?           ]]
 ] [
     uncons over intrinsic
     [ literal, 0 , \ binary-op , ] make-list

library/compiler/linearizer.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-frontend
-USING: inference kernel lists math namespaces words strings
+USING: compiler-backend inference kernel lists math namespaces
-errors prettyprint kernel-internals ;
+words strings errors prettyprint kernel-internals ;
 
 : >linear ( node -- )
     #! Dataflow OPs have a linearizer word property. This
@@ -21,12 +21,6 @@ errors prettyprint kernel-internals ;
     #! rest is arguments.
     [ %prologue , (linearize) ] make-list ;
 
-: <label> ( -- label )
-    gensym  dup t "label" set-word-prop ;
-
-: label? ( obj -- ? )
-    dup word? [ "label" word-prop ] [ drop f ] ifte ;
-
 : linearize-simple-label ( node -- )
     #! Some labels become simple labels after the optimization
     #! stage.
@@ -46,7 +40,7 @@ errors prettyprint kernel-internals ;
     #! not contain non-tail recursive calls to itself.
     <label> dup %return-to , >r
     linearize-simple-label
-    %return ,
+    f %return ,
     r> %label , ;
 
 #label [
@@ -105,4 +99,4 @@ errors prettyprint kernel-internals ;
 
 #values [ drop ] "linearizer" set-word-prop
 
-#return [ drop %return , ] "linearizer" set-word-prop
+#return [ drop f %return , ] "linearizer" set-word-prop

library/compiler/optimizer.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-frontend
 USING: inference kernel kernel-internals lists namespaces
 sequences vectors words words ;
 

library/compiler/simplifier.factor

@@ -1,141 +1,217 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: inference kernel lists math namespaces prettyprint
+USING: generic inference kernel lists math namespaces
-strings words ;
+prettyprint strings words ;
 
-: simplify ;
+! A peephole optimizer operating on the linear IR.
 
 ! The linear IR being simplified is stored in this variable.
-! SYMBOL: simplifying
+SYMBOL: simplifying
-! 
+
-! : simplifiers ( linear -- list )
+GENERIC: simplify-node ( linear vop -- linear ? )
-!     #! A list of quotations with stack effect
+
-!     #! ( linear -- linear ? ) that can simplify the first node
+! The next node following this node in terms of control flow, or
-!     #! in the linear IR.
+! f if this is a conditional.
-!     car car "simplifiers" word-prop ;
+GENERIC: next-logical ( linear vop -- linear )
-! 
+
-! : simplify-node ( linear list -- linear ? )
+! No delegation.
-!     dup [
+M: tuple simplify-node drop f ;
-!         uncons >r call [
+
-!             r> drop t
+: simplify-1 ( list -- list ? )
-!         ] [
+    #! Return a new linear IR.
-!             r> simplify-node
+     dup [
-!         ] ifte
+         dup car simplify-node
-!     ] when ;
+         [ uncons simplify-1 drop cons t ]
-! 
+         [ uncons simplify-1 >r cons r> ] ifte
-! : simplify-1 ( linear -- linear ? )
+     ] [
-!     #! Return a new linear IR.
+         f
-!     dup [
+     ] ifte ;
-!         dup simplifiers simplify-node
+
-!         [ uncons simplify-1 drop cons t ]
+: simplify ( linear -- linear )
-!         [ uncons simplify-1 >r cons r> ] ifte
+    #! Keep simplifying until simplify-1 returns f.
-!     ] [
+    [
-!         f
+        dup simplifying set  simplify-1
-!     ] ifte ;
+    ] with-scope  [ simplify ] when ;
-! 
+
-! : simplify ( linear -- linear )
+: label-called? ( label -- ? )
-!     #! Keep simplifying until simplify-1 returns f.
+    simplifying get [ calls-label? ] some-with? ;
-!     [
+
-!         dup simplifying set  simplify-1
+M: %label simplify-node ( linear vop -- linear ? )
-!     ] with-scope  [ simplify ] when ;
+    vop-label label-called? [ f ] [ cdr t ] ifte ;
-! 
+
-! : label-called? ( label linear -- ? )
+: next-physical? ( linear class -- vop ? )
-!     [ uncons pick = swap #label = not and ] some? nip ;
+    #! If the following op has given class, remove it and
-! 
+    #! return it.
-! #label [
+    over cdr dup [
-!     [
+        car class = [ cdr car t ] [ f ] ifte
-!         dup car cdr simplifying get label-called?
+    ] [
-!         [ f ] [ cdr t ] ifte
+        3drop f f
-!     ]
+    ] ifte ;
-! ] "simplifiers" set-word-prop
+
-! 
+M: %inc-d simplify-node ( linear vop -- linear ? )
-! : next-physical? ( op linear -- ? )
+    #! %inc-d cancels a following %inc-d.
-!     cdr dup [ car car = ] [ 2drop f ] ifte ;
+    >r dup \ %inc-d next-physical? [
-! 
+        vop-literal r> vop-literal + dup 0 = [
-! : cancel ( linear op -- linear param ? )
+            drop cdr cdr f
-!     #! If the following op is as given, remove it, and return
+        ] [
-!     #! its param.
+            %inc-d >r cdr cdr r> swons t
-!     over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
+        ] ifte
-! 
+    ] [
-! \ drop [
+        r> 2drop f
-!     [
+    ] ifte ;
-!         #push-immediate cancel [
+
-!             #replace-immediate swons swons t
+: dead-load? ( linear vop -- ? )
-!         ] when
+    #! Is the %replace-d followed by a %peek-d of the same
-!     ] [
+    #! stack slot and vreg?
-!         #push-indirect cancel [
+    swap cdr car dup %peek-d? [
-!             #replace-indirect swons swons t
+        over vop-source over vop-dest = >r
-!         ] when
+        swap vop-literal swap vop-literal = r> and
-!     ]
+    ] [
-! ] "simplifiers" set-word-prop
+        2drop f
-! 
+    ] ifte ;
-! : find-label ( label -- rest )
+
-!     simplifying get [
+: dead-store? ( linear n -- ? )
-!         uncons pick = swap #label = and
+    #! Is the %replace-d followed by a %dec-d, so the stored
-!     ] some? nip ;
+    #! value is lost?
-! 
+    swap \ %inc-d next-physical? [
-! : next-logical ( linear -- linear )
+        vop-literal + 0 <
-!     dup car car "next-logical" word-prop call ;
+    ] [
-! 
+        2drop f
-! #label [
+    ] ifte ;
-!     cdr next-logical
+
-! ] "next-logical" set-word-prop
+M: %replace-d simplify-node ( linear vop -- linear ? )
-! 
+    2dup dead-load? [
-! #jump-label [
+        drop uncons cdr cons t
-!     car cdr find-label cdr
+    ] [
-! ] "next-logical" set-word-prop
+        2dup vop-literal dead-store? [
-! 
+            drop cdr t
-! #target-label [
+        ] [
-!     car cdr find-label cdr
+            drop f
-! ] "next-logical" set-word-prop
+        ] ifte
-! 
+    ] ifte ;
-! : next-logical? ( op linear -- ? )
+
-!     next-logical dup [ car car = ] [ 2drop f ] ifte ;
+M: %immediate-d simplify-node ( linear vop -- linear ? )
-! 
+    over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
-! : reduce ( linear op new -- linear ? )
+
-!     >r over cdr next-logical? [
+: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
-!         unswons cdr r> swons swons t
+
-!     ] [
+: can-fast-branch? ( linear -- ? )
-!         r> drop f
+    unswons class fast-branch [
-!     ] ifte ;
+        unswons pop? [ car %jump-t? ] [ drop f ] ifte
-! 
+    ] [
-! #call [
+        drop f
-!     [ #return #jump reduce ]
+    ] ifte ;
-! ] "simplifiers" set-word-prop
+
-! 
+: fast-branch-params ( linear -- src dest label linear )
-! #call-label [
+    uncons >r dup vop-source swap vop-dest r> cdr
-!     [ #return #jump-label reduce ]
+    uncons >r vop-label r> ;
-! ] "simplifiers" set-word-prop
+
-! 
+M: %fixnum<= simplify-node ( linear vop -- linear ? )
-! : double-jump ( linear op1 op2 -- linear ? )
+    drop dup can-fast-branch? [
-!     #! A jump to a jump is just a jump. If the next logical node
+        fast-branch-params >r
-!     #! is a jump of type op1, replace the jump at the car of the
+        %jump-fixnum<= >r -1 %inc-d r>
-!     #! list with a jump of type op2.
+        r> cons cons t
-!     swap pick next-logical? [
+    ] [
-!         over next-logical car cdr cons swap cdr cons t
+        f
-!     ] [
+    ] ifte ;
-!         drop f
+
-!     ] ifte ;
+M: %eq? simplify-node ( linear vop -- linear ? )
-! 
+    drop dup can-fast-branch? [
-! : useless-jump ( linear -- linear ? )
+        fast-branch-params >r
-!     #! A jump to a label immediately following is not needed.
+        %jump-eq? >r -1 %inc-d r>
-!     dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
+        r> cons cons t
-! 
+    ] [
-! : (dead-code) ( linear -- linear ? )
+        f
-!     #! Remove all nodes until the next #label.
+    ] ifte ;
-!     dup [
+
-!         dup car car #label = [
+: find-label ( label -- rest )
-!             f
+    simplifying get [
-!         ] [
+        dup %label? [ vop-label = ] [ 2drop f ] ifte
-!             cdr (dead-code) t or
+    ] some-with? ;
-!         ] ifte
+
-!     ] [
+M: %label next-logical ( linear vop -- linear )
-!         f
+    drop cdr dup car next-logical ;
-!     ] ifte ;
+
-! 
+M: %jump-label next-logical ( linear vop -- linear )
-! : dead-code ( linear -- linear ? )
+    nip vop-label find-label cdr ;
-!     uncons (dead-code) >r cons r> ;
+
+M: %target-label next-logical ( linear vop -- linear )
+    nip vop-label find-label cdr ;
+
+M: object next-logical ( linear vop -- linear )
+    drop ;
+
+: next-logical? ( op linear -- ? )
+    dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
+
+: reduce ( linear op new -- linear ? )
+    >r over cdr next-logical? [
+        dup car vop-label
+        r> execute swap cdr cons t
+    ] [
+        r> drop f
+    ] ifte ; inline
+
+M: %call simplify-node ( linear vop -- ? )
+    #! Tail call optimization.
+    drop \ %return \ %jump reduce ;
+
+M: %call-label simplify-node ( linear vop -- ? )
+    #! Tail call optimization.
+    drop \ %return \ %jump-label reduce ;
+
+: double-jump ( linear op2 op1 -- linear ? )
+    #! A jump to a jump is just a jump. If the next logical node
+    #! is a jump of type op1, replace the jump at the car of the
+    #! list with a jump of type op2.
+    pick next-logical? [
+        >r dup dup car next-logical car vop-label
+        r> execute swap cdr cons t
+    ] [
+        drop f
+    ] ifte ; inline
+
+: useless-jump ( linear -- linear ? )
+    #! A jump to a label immediately following is not needed.
+    dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
+
+: (dead-code) ( linear -- linear ? )
+    #! Remove all nodes until the next #label.
+    dup [
+        dup car %label? [
+            f
+        ] [
+            cdr (dead-code) t or
+        ] ifte
+    ] [
+        f
+    ] ifte ;
+
+: dead-code ( linear -- linear ? )
+    uncons (dead-code) >r cons r> ;
+
+M: %jump-label simplify-node ( linear vop -- ? )
+    drop
+    \ %return dup double-jump [
+        t
+    ] [
+        \ %jump-label dup double-jump [
+            t
+        ] [
+            \ %jump dup double-jump
+            ! [
+            !     t
+            ! ] [
+            !     useless-jump [
+            !         t
+            !     ] [
+            !         dead-code
+            !     ] ifte
+            ! ] ifte
+        ] ifte
+    ] ifte ;
+
 ! 
 ! #jump-label [
 !     [ #return #return double-jump ]
@@ -146,8 +222,8 @@ strings words ;
 ! ] "simplifiers" set-word-prop
 ! 
 ! #target-label [
-!     [ #jump-label #target-label double-jump ]
+!     [ #target-label #jump-label double-jump ]
-! !   [ #jump #target double-jump ]
+! !   [ #target #jump double-jump ]
 ! ] "simplifiers" set-word-prop
 ! 
 ! #jump [ [ dead-code ] ] "simplifiers" set-word-prop

library/compiler/vops.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: errors generic kernel namespaces parser ;
+USING: errors generic hashtables kernel math namespaces parser
+words ;
 
 ! The linear IR is the second of the two intermediate
 ! representations used by Factor. It is basically a high-level
@@ -10,14 +11,22 @@ USING: errors generic kernel namespaces parser ;
 ! This file defines all the types of VOPs. A linear IR program
 ! is then just a list of VOPs.
 
+: <label> ( -- label )
+    #! Make a label.
+    gensym  dup t "label" set-word-prop ;
+
+: label? ( obj -- ? )
+    dup word? [ "label" word-prop ] [ drop f ] ifte ;
+
 ! A virtual register
 TUPLE: vreg n ;
 
 ! A virtual operation
 TUPLE: vop source dest literal label ;
 
-! Compile a VOP.
+GENERIC: calls-label? ( label vop -- ? )
-GENERIC: generate-node ( vop -- )
+
+M: vop calls-label? vop-label = ;
 
 : make-vop ( source dest literal label vop -- vop )
     [ >r <vop> r> set-delegate ] keep ;
@@ -40,8 +49,14 @@ VOP: %prologue
 : %prologue empty-vop <%prologue> ;
 VOP: %label
 : %label label-vop <%label> ;
+M: %label calls-label? 2drop f ;
+
+! Return vops take a label that is ignored, to have the
+! same stack effect as jumps. This is needed for the
+! simplifier.
 VOP: %return
-: %return empty-vop <%return> ;
+: %return ( label) label-vop <%return> ;
+
 VOP: %return-to
 : %return-to label-vop <%return-to> ;
 VOP: %jump
@@ -70,23 +85,23 @@ VOP: %end-dispatch
 ! stack operations
 VOP: %peek-d
 : %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
-VOP: %dec-d
-: %dec-d ( n -- ) literal-vop <%dec-d> ;
 VOP: %replace-d
 : %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
 VOP: %inc-d
 : %inc-d ( n -- ) literal-vop <%inc-d> ;
+: %dec-d ( n -- ) neg %inc-d ;
 VOP: %immediate
 VOP: %immediate-d
 : %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
 VOP: %peek-r
 : %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
-VOP: %dec-r
-: %dec-r ( n -- ) literal-vop <%dec-r> ;
 VOP: %replace-r
 : %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
 VOP: %inc-r
 : %inc-r ( n -- ) literal-vop <%inc-r> ;
+! this exists, unlike %dec-d which does not, due to x86 quirks
+VOP: %dec-r
+: %dec-r ( n -- ) literal-vop <%dec-r> ;
 
 : in-1 0 0 %peek-d , ;
 : in-2 0 1 %peek-d ,  1 0 %peek-d , ;
@@ -128,13 +143,28 @@ VOP: %fixnum-bitor  : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
 VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
 VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
 VOP: %fixnum-shift  : %fixnum-shift src/dest-vop <%fixnum-shift> ;
+
 VOP: %fixnum<=      : %fixnum<= src/dest-vop <%fixnum<=> ;
 VOP: %fixnum<       : %fixnum< src/dest-vop <%fixnum<> ;
 VOP: %fixnum>=      : %fixnum>= src/dest-vop <%fixnum>=> ;
 VOP: %fixnum>       : %fixnum> src/dest-vop <%fixnum>> ;
-
 VOP: %eq?           : %eq? src/dest-vop <%eq?> ;
 
+VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ;
+VOP: %jump-fixnum<  : %jump-fixnum< f swap <%jump-fixnum<> ;
+VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ;
+VOP: %jump-fixnum>  : %jump-fixnum> f swap <%jump-fixnum>> ;
+VOP: %jump-eq?      : %jump-eq? f swap <%jump-eq?> ;
+
+: fast-branch ( class -- class )
+    {{
+        [[ %fixnum<= %jump-fixnum<= ]]
+        [[ %fixnum<  %jump-fixnum<  ]]
+        [[ %fixnum>= %jump-fixnum>= ]]
+        [[ %fixnum>  %jump-fixnum>  ]]
+        [[ %eq?      %jump-eq?      ]]
+    }} hash ;
+
 ! some slightly optimized inline assembly
 VOP: %type
 : %type ( vreg ) <vreg> dest-vop <%type> ;

library/compiler/x86/alien.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
 USING: alien assembler inference kernel kernel-internals lists
 math memory namespaces words ;
 

library/compiler/x86/fixnum.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: assembler errors kernel math math-internals memory
+USING: assembler compiler errors kernel math math-internals
-namespaces words ;
+memory namespaces words ;
 
 : simple-overflow ( dest -- )
     #! If the previous arithmetic operation overflowed, then we
@@ -130,3 +130,22 @@ M: %fixnum>= generate-node ( vop -- )
 
 M: %eq? generate-node ( vop -- )
     fixnum-compare  \ JE  conditional ;
+
+: fixnum-branch ( vop -- label )
+    dup vop-dest v>operand over vop-source v>operand CMP
+    vop-label ;
+
+M: %jump-fixnum< generate-node ( vop -- )
+    fixnum-branch JL ;
+
+M: %jump-fixnum<= generate-node ( vop -- )
+    fixnum-branch JLE ;
+
+M: %jump-fixnum> generate-node ( vop -- )
+    fixnum-branch JG ;
+
+M: %jump-fixnum>= generate-node ( vop -- )
+    fixnum-branch JGE ;
+
+M: %jump-eq? generate-node ( vop -- )
+    fixnum-branch JE ;

library/compiler/x86/generator.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: alien assembler inference kernel kernel-internals lists
+USING: alien assembler compiler inference kernel
-math memory namespaces sequences words ;
+kernel-internals lists math memory namespaces sequences words ;
 
 GENERIC: v>operand
 M: integer v>operand address ;

library/compiler/x86/stack.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
+IN: compiler-backend
-USING: alien assembler inference kernel lists math memory
+USING: alien assembler compiler inference kernel lists math
-sequences words ;
+memory sequences words ;
 
 : rel-cs ( -- )
     #! Add an entry to the relocation table for the 32-bit
@@ -20,14 +20,12 @@ sequences words ;
 M: %peek-d generate-node ( vop -- )
     dup vop-dest v>operand swap vop-literal ds-op MOV ;
 
-M: %dec-d generate-node ( vop -- )
-    vop-literal ESI swap cell * SUB ;
-
 M: %replace-d generate-node ( vop -- )
     dup vop-source v>operand swap vop-literal ds-op swap MOV ;
 
 M: %inc-d generate-node ( vop -- )
-    vop-literal ESI swap cell * ADD ;
+    ESI swap vop-literal cell *
+    dup 0 > [ ADD ] [ neg SUB ] ifte ;
 
 M: %immediate generate-node ( vop -- )
     dup vop-dest v>operand swap vop-literal address MOV ;

library/generic/tuple.factor

@@ -68,8 +68,9 @@ 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 swap [ swap class eq? ] cons
+    dup predicate-word swap [
-    define-compound ;
+        literal, [ swap class eq? ] %
+    ] make-list define-compound ;
 
 : check-shape ( word slots -- )
     #! If the new list of slots is different from the previous,

library/inference/words.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: errors generic interpreter kernel lists math namespaces
+USING: errors generic interpreter kernel lists math
-sequences strings vectors words hashtables parser prettyprint ;
+math-internals namespaces sequences strings vectors words
+hashtables parser prettyprint ;
 
 : with-dataflow ( param op [[ in# out# ]] quot -- )
     #! Take input parameters, execute quotation, take output
@@ -170,8 +171,17 @@ M: word apply-object ( word -- )
 \ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
 \ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
 \ + [ [ number number ] [ number ] ] "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
 
 \ no-method t "terminator" set-word-prop
 \ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop

library/test/benchmark/fib.factor

@@ -20,3 +20,19 @@ USE: math-internals
     compiled
 
 [ 9227465 ] [ 34 fib ] unit-test
+
+TUPLE: box i ;
+
+: tuple-fib ( n -- n )
+    dup box-i 1 <= [
+        drop 1 <box>
+    ] [
+        box-i 1 - <box>
+        dup tuple-fib
+        swap
+        box-i 1 - <box>
+        tuple-fib
+        swap box-i swap box-i + <box>
+    ] ifte ; compiled
+
+[ << box f 9227465 ] [ << box f 34 >> tuple-fib ] unit-test

library/test/compiler/intrinsics.factor

@@ -32,6 +32,9 @@ math-internals test words ;
 [ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
 [ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
 [ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
+[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test
+[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
+[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
 
 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test

library/test/tuple.factor

@@ -51,3 +51,8 @@ C: quuux-tuple-2
     
     point-x
 ] unit-test
+
+TUPLE: predicate-test ;
+: predicate-test drop f ;
+
+[ t ] [ <predicate-test> predicate-test? ] unit-test