linear IR and simplifier refactoring

CHANGES.txt

@@ -7,6 +7,9 @@ for controlling it:
  +Yn   Size of 2 youngest generations, megabytes
  +An   Size of tenured and semi-spaces, megabytes
 
+The compiler now does constant folding for certain words with literal
+operands. The compiler's peephole optimizer has been improved.
+
 The alien interface now supports "float" and "double" types.
 
 Defining a predicate subclass of tuple is supported now. Note that

library/bootstrap/boot-stage2.factor

@@ -30,11 +30,9 @@ t [
     "/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/simplifier.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-backend
 USING: generic inference kernel lists math namespaces
-prettyprint strings words ;
+prettyprint sequences strings words ;
 
 ! A peephole optimizer operating on the linear IR.
 
@@ -51,51 +51,91 @@ M: %label simplify-node ( linear vop -- linear ? )
 
 M: %inc-d simplify-node ( linear vop -- linear ? )
     #! %inc-d cancels a following %inc-d.
-    dup vop-literal 0 = [
+    dup vop-in-1 0 = [
         drop cdr t
     ] [
         >r dup \ %inc-d next-physical? [
-            vop-literal r> vop-literal + 
+            vop-in-1 r> vop-in-1 + 
             %inc-d >r cdr cdr r> swons t
         ] [
             r> 2drop f
         ] ifte
     ] ifte ;
 
-: dead-load? ( linear vop -- ? )
+: basic-block ( linear quot -- | quot: vop -- ? )
+    #! Keep applying the quotation to each VOP until either a
+    #! VOP answering f to basic-block?, or the quotation answers
+    #! f.
+    over car basic-block? [
+        >r uncons r> tuck >r >r call [
+            r> r> basic-block
+        ] [
+            r> r> 2drop
+        ] ifte
+    ] [
+        2drop
+    ] ifte ; inline
+
+: reads-vreg? ( vreg linear -- ? )
+    #! Tests if the vreg is read before being written in the
+    #! current basic block. Outputs a true value if the vreg
+    #! is not read or written before the end of the basic block.
+    [
+        2dup vop-inputs contains? [
+            ! we are reading the vreg
+            2drop t f
+        ] [
+            2dup vop-outputs contains? [
+                ! we are writing the vreg
+                2drop f f
+            ] [
+                ! keep checking
+                drop t
+            ] ifte
+        ] ifte
+    ] basic-block ;
+
+: dead-load ( vreg linear -- linear ? )
+    #! If the vreg is not read before being written, drop
+    #! the current VOP.
+    tuck cdr reads-vreg? [ f ] [ cdr t ] ifte ;
+
+M: %peek-d simplify-node ( linear vop -- linear ? )
+    vop-out-1 swap dead-load ;
+
+M: %immediate simplify-node ( linear vop -- linear ? )
+    vop-out-1 swap dead-load ;
+
+M: %indirect simplify-node ( linear vop -- linear ? )
+    vop-out-1 swap dead-load ;
+
+: dead-peek? ( linear vop -- ? )
     #! Is the %replace-d followed by a %peek-d of the same
     #! stack slot and vreg?
     swap cdr car dup %peek-d? [
-        over vop-source over vop-dest = >r
+        over vop-in-2 over vop-out-1 = >r
-        swap vop-literal swap vop-literal = r> and
+        swap vop-in-1 swap vop-in-1 = r> and
     ] [
         2drop f
     ] ifte ;
 
-: dead-store? ( linear n -- ? )
+: dead-replace? ( linear n -- ? )
     #! Is the %replace-d followed by a %dec-d, so the stored
     #! value is lost?
     swap \ %inc-d next-physical? [
-        vop-literal + 0 <
+        vop-in-1 + 0 <
     ] [
         2drop f
     ] ifte ;
 
 M: %replace-d simplify-node ( linear vop -- linear ? )
-    2dup dead-load? [
+    2dup dead-peek? [
         drop uncons cdr cons t
     ] [
-        2dup vop-literal dead-store? [
+        dupd vop-in-1 dead-replace? [ cdr t ] [ f ] ifte
-            drop cdr t
-        ] [
-            drop f
-        ] ifte
     ] ifte ;
 
-! M: %immediate-d simplify-node ( linear vop -- linear ? )
+: pop? ( vop -- ? ) dup %inc-d? swap vop-in-1 -1 = and ;
-!     over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
-
-: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
 
 : can-fast-branch? ( linear -- ? )
     unswons class fast-branch [
@@ -105,7 +145,7 @@ M: %replace-d simplify-node ( linear vop -- linear ? )
     ] ifte ;
 
 : fast-branch-params ( linear -- src dest label linear )
-    uncons >r dup vop-source swap vop-dest r> cdr
+    uncons >r dup vop-in-1 swap vop-out-1 r> cdr
     uncons >r vop-label r> ;
 
 : make-fast-branch ( linear op -- linear ? )

library/compiler/vops.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-backend
-USING: errors generic hashtables kernel math namespaces parser
+USING: errors generic hashtables kernel lists math namespaces
-words ;
+parser sequences words ;
 
 ! The linear IR is the second of the two intermediate
 ! representations used by Factor. It is basically a high-level
@@ -22,13 +22,21 @@ words ;
 TUPLE: vreg n ;
 
 ! A virtual operation
-TUPLE: vop source dest literal label ;
+TUPLE: vop inputs outputs label ;
+: vop-in-1 ( vop -- input ) vop-inputs car ;
+: vop-in-2 ( vop -- input ) vop-inputs cdr car ;
+: vop-in-3 ( vop -- input ) vop-inputs cdr cdr car ;
+: vop-out-1 ( vop -- output ) vop-outputs car ;
+
+GENERIC: basic-block? ( vop -- ? )
+M: vop basic-block? drop f ;
+! simplifies some code
+M: f basic-block? drop f ;
 
 GENERIC: calls-label? ( label vop -- ? )
-
 M: vop calls-label? vop-label = ;
 
-: make-vop ( source dest literal label vop -- vop )
+: make-vop ( inputs outputs label vop -- vop )
     [ >r <vop> r> set-delegate ] keep ;
 
 : VOP:
@@ -36,19 +44,21 @@ M: vop calls-label? vop-label = ;
     scan dup [ ] define-tuple
     create-in [ make-vop ] define-constructor ; parsing
 
-: empty-vop f f f f ;
+: empty-vop f f f ;
-: label-vop ( label) >r f f f r> ;
+: label-vop ( label) >r f f r> ;
-: label/src-vop ( label src) swap >r f f r> ;
+: label/src-vop ( label src) unit swap f swap ;
-: src-vop ( src) f f f ;
+: src-vop ( src) unit f f ;
-: dest-vop ( dest) f swap f f ;
+: dest-vop ( dest) unit dup f ;
-: src/dest-vop ( src dest) f f ;
+: src/dest-vop ( src dest) >r unit r> unit f ;
-: literal-vop ( literal) >r f f r> f ;
+: binary-vop ( src dest) [ 2list ] keep unit f ;
-: src/literal-vop ( src literal) f swap f ;
+: 2-in-vop ( in1 in2) 2list f f ;
-: dest/literal-vop ( dest literal) >r f swap r> f ;
+: 2-in/label-vop ( in1 in2 label) >r 2list f r> ;
+: ternary-vop ( in1 in2 dest) >r 2list r> unit f ;
 
 ! miscellanea
 VOP: %prologue
 : %prologue empty-vop <%prologue> ;
+
 VOP: %label
 : %label label-vop <%label> ;
 M: %label calls-label? 2drop f ;
@@ -61,49 +71,69 @@ VOP: %return
 
 VOP: %return-to
 : %return-to label-vop <%return-to> ;
+
 VOP: %jump
 : %jump label-vop <%jump> ;
+
 VOP: %jump-label
 : %jump-label label-vop <%jump-label> ;
+
 VOP: %call
 : %call label-vop <%call> ;
+
 VOP: %call-label
 : %call-label label-vop <%call-label> ;
+
 VOP: %jump-t
 : %jump-t <vreg> label/src-vop <%jump-t> ;
+
 VOP: %jump-f
 : %jump-f <vreg> label/src-vop <%jump-f> ;
 
 ! dispatch tables
 VOP: %dispatch
 : %dispatch <vreg> src-vop <%dispatch> ;
+
 VOP: %target-label
 : %target-label label-vop <%target-label> ;
+
 VOP: %target
 : %target label-vop <%target> ;
+
 VOP: %end-dispatch
 : %end-dispatch empty-vop <%end-dispatch> ;
 
 ! stack operations
 VOP: %peek-d
-: %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
+: %peek-d ( vreg n -- ) swap <vreg> src/dest-vop <%peek-d> ;
+M: %peek-d basic-block? drop t ;
+
 VOP: %replace-d
-: %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
+: %replace-d ( vreg n -- ) swap <vreg> 2-in-vop <%replace-d> ;
+M: %replace-d basic-block? drop t ;
+
 VOP: %inc-d
-: %inc-d ( n -- ) literal-vop <%inc-d> ;
+: %inc-d ( n -- ) src-vop <%inc-d> ;
 : %dec-d ( n -- ) neg %inc-d ;
+M: %inc-d basic-block? drop t ;
+
 VOP: %immediate
 : %immediate ( vreg obj -- )
-    >r <vreg> r> dest/literal-vop <%immediate> ;
+    swap <vreg> src/dest-vop <%immediate> ;
+M: %immediate basic-block? drop t ;
+
 VOP: %peek-r
-: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
+: %peek-r ( vreg n -- ) swap <vreg> src/dest-vop <%peek-r> ;
+
 VOP: %replace-r
-: %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
+: %replace-r ( vreg n -- ) swap <vreg> 2-in-vop <%replace-r> ;
+
 VOP: %inc-r
-: %inc-r ( n -- ) literal-vop <%inc-r> ;
+: %inc-r ( n -- ) src-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> ;
+: %dec-r ( n -- ) src-vop <%dec-r> ;
 
 : in-1 0 0 %peek-d , ;
 : in-2 0 1 %peek-d ,  1 0 %peek-d , ;
@@ -112,44 +142,58 @@ VOP: %dec-r
 
 ! indirect load of a literal through a table
 VOP: %indirect
-: %indirect ( vreg obj -- ) >r <vreg> r> f -rot f <%indirect> ;
+: %indirect ( vreg obj -- )
+    swap <vreg> src/dest-vop <%indirect> ;
+M: %indirect basic-block? drop t ;
 
 ! object slot accessors
 ! mask off a tag (see also %untag-fixnum)
 VOP: %untag
 : %untag <vreg> dest-vop <%untag> ;
+M: %untag basic-block? drop t ;
+
 VOP: %slot
-: %slot ( n vreg ) >r <vreg> r> <vreg> f f <%slot> ;
+: %slot ( n vreg ) >r <vreg> r> <vreg> binary-vop <%slot> ;
+M: %slot basic-block? drop t ;
 
 VOP: %set-slot
-: %set-slot ( vreg:value vreg:obj n )
+: %set-slot ( value obj n )
-    >r >r <vreg> r> <vreg> r> <vreg> f <%set-slot> ;
+    #! %set-slot writes to vreg n.
+    >r >r <vreg> r> <vreg> r> <vreg> [ 3list ] keep unit f
+    <%set-slot> ;
+M: %set-slot basic-block? drop t ;
 
 ! in the 'fast' versions, the object's type and slot number is
 ! known at compile time, so these become a single instruction
 VOP: %fast-slot
-: %fast-slot ( vreg n ) >r >r f r> <vreg> r> f <%fast-slot> ;
+: %fast-slot ( vreg n )
+    swap <vreg> binary-vop <%fast-slot> ;
+M: %fast-slot basic-block? drop t ;
+
 VOP: %fast-set-slot
-: %fast-set-slot ( vreg:value vreg:obj n )
+: %fast-set-slot ( value obj n )
-    >r >r <vreg> r> <vreg> r> f <%fast-set-slot> ;
+    #! %fast-set-slot writes to vreg obj.
+    >r >r <vreg> r> <vreg> r> over >r 3list r> unit f
+    <%fast-set-slot> ;
+M: %fast-set-slot basic-block? drop t ;
 
 ! fixnum intrinsics
-VOP: %fixnum+       : %fixnum+ src/dest-vop <%fixnum+> ;
+VOP: %fixnum+       : %fixnum+ binary-vop <%fixnum+> ;
-VOP: %fixnum-       : %fixnum- src/dest-vop <%fixnum-> ;
+VOP: %fixnum-       : %fixnum- binary-vop <%fixnum-> ;
-VOP: %fixnum*       : %fixnum* src/dest-vop <%fixnum*> ;
+VOP: %fixnum*       : %fixnum* binary-vop <%fixnum*> ;
-VOP: %fixnum-mod    : %fixnum-mod src/dest-vop <%fixnum-mod> ;
+VOP: %fixnum-mod    : %fixnum-mod binary-vop <%fixnum-mod> ;
-VOP: %fixnum/i      : %fixnum/i src/dest-vop <%fixnum/i> ;
+VOP: %fixnum/i      : %fixnum/i binary-vop <%fixnum/i> ;
-VOP: %fixnum/mod    : %fixnum/mod src/dest-vop <%fixnum/mod> ;
+VOP: %fixnum/mod    : %fixnum/mod binary-vop <%fixnum/mod> ;
-VOP: %fixnum-bitand : %fixnum-bitand src/dest-vop <%fixnum-bitand> ;
+VOP: %fixnum-bitand : %fixnum-bitand binary-vop <%fixnum-bitand> ;
-VOP: %fixnum-bitor  : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
+VOP: %fixnum-bitor  : %fixnum-bitor binary-vop <%fixnum-bitor> ;
-VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
+VOP: %fixnum-bitxor : %fixnum-bitxor binary-vop <%fixnum-bitxor> ;
 VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
 
-VOP: %fixnum<=      : %fixnum<= src/dest-vop <%fixnum<=> ;
+VOP: %fixnum<=      : %fixnum<= binary-vop <%fixnum<=> ;
-VOP: %fixnum<       : %fixnum< src/dest-vop <%fixnum<> ;
+VOP: %fixnum<       : %fixnum< binary-vop <%fixnum<> ;
-VOP: %fixnum>=      : %fixnum>= src/dest-vop <%fixnum>=> ;
+VOP: %fixnum>=      : %fixnum>= binary-vop <%fixnum>=> ;
-VOP: %fixnum>       : %fixnum> src/dest-vop <%fixnum>> ;
+VOP: %fixnum>       : %fixnum> binary-vop <%fixnum>> ;
-VOP: %eq?           : %eq? src/dest-vop <%eq?> ;
+VOP: %eq?           : %eq? binary-vop <%eq?> ;
 
 ! At the VOP level, the 'shift' operation is split into five
 ! distinct operations:
@@ -159,19 +203,28 @@ VOP: %eq?           : %eq? src/dest-vop <%eq?> ;
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a small negative count: %fixnum>>
 ! - shifts with a large negative count: %fixnum-sgn
-VOP: %fixnum<<   : %fixnum<<   src/dest-vop <%fixnum<<> ;
+VOP: %fixnum<<   : %fixnum<<   binary-vop <%fixnum<<> ;
-VOP: %fixnum>>   : %fixnum>>   src/dest-vop <%fixnum>>> ;
+VOP: %fixnum>>   : %fixnum>>   binary-vop <%fixnum>>> ;
 ! due to x86 limitations the destination of this VOP must be
 ! vreg 2 (EDX), and the source must be vreg 0 (EAX).
-VOP: %fixnum-sgn : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
+VOP: %fixnum-sgn : %fixnum-sgn binary-vop <%fixnum-sgn> ;
 
 ! Integer comparison followed by a conditional branch is
 ! optimized
-VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ;
+VOP: %jump-fixnum<=
-VOP: %jump-fixnum<  : %jump-fixnum< f swap <%jump-fixnum<> ;
+: %jump-fixnum<= 2-in/label-vop <%jump-fixnum<=> ;
-VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ;
+
-VOP: %jump-fixnum>  : %jump-fixnum> f swap <%jump-fixnum>> ;
+VOP: %jump-fixnum< 
-VOP: %jump-eq?      : %jump-eq? f swap <%jump-eq?> ;
+: %jump-fixnum< 2-in/label-vop <%jump-fixnum<> ;
+
+VOP: %jump-fixnum>=
+: %jump-fixnum>= 2-in/label-vop <%jump-fixnum>=> ;
+
+VOP: %jump-fixnum> 
+: %jump-fixnum> 2-in/label-vop <%jump-fixnum>> ;
+
+VOP: %jump-eq?     
+: %jump-eq? 2-in/label-vop <%jump-eq?> ;
 
 : fast-branch ( class -- class )
     {{
@@ -190,55 +243,62 @@ PREDICATE: tuple fast-branch
 ! some slightly optimized inline assembly
 VOP: %type
 : %type ( vreg ) <vreg> dest-vop <%type> ;
+M: %type basic-block? drop t ;
 
 VOP: %arithmetic-type
 : %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
 
 VOP: %tag-fixnum
 : %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
+M: %tag-fixnum basic-block? drop t ;
 
 VOP: %untag-fixnum
 : %untag-fixnum <vreg> dest-vop <%untag-fixnum> ;
+M: %untag-fixnum basic-block? drop t ;
 
 : check-dest ( vop reg -- )
-    swap vop-dest = [ "invalid VOP destination" throw ] unless ;
+    swap vop-out-1 = [
+        "invalid VOP destination" throw
+    ] unless ;
 
 VOP: %getenv
-: %getenv dest/literal-vop <%getenv> ;
+: %getenv swap src/dest-vop <%getenv> ;
+M: %getenv basic-block? drop t ;
 
 VOP: %setenv
-: %setenv src/literal-vop <%setenv> ;
+: %setenv 2-in-vop <%setenv> ;
+M: %setenv basic-block? drop t ;
 
 ! alien operations
 VOP: %parameters
-: %parameters ( n -- vop ) literal-vop <%parameters> ;
+: %parameters ( n -- vop ) src-vop <%parameters> ;
 
 VOP: %parameter
-: %parameter ( n -- vop ) literal-vop <%parameter> ;
+: %parameter ( n -- vop ) src-vop <%parameter> ;
 
 VOP: %cleanup
-: %cleanup ( n -- vop ) literal-vop <%cleanup> ;
+: %cleanup ( n -- vop ) src-vop <%cleanup> ;
 
 VOP: %unbox
-: %unbox ( [[ n func ]] -- vop ) literal-vop <%unbox> ;
+: %unbox ( [[ n func ]] -- vop ) src-vop <%unbox> ;
 
 VOP: %unbox-float
-: %unbox-float ( [[ n func ]] -- vop ) literal-vop <%unbox-float> ;
+: %unbox-float ( [[ n func ]] -- vop ) src-vop <%unbox-float> ;
 
 VOP: %unbox-double
-: %unbox-double ( [[ n func ]] -- vop ) literal-vop <%unbox-double> ;
+: %unbox-double ( [[ n func ]] -- vop ) src-vop <%unbox-double> ;
 
 VOP: %box
-: %box ( func -- vop ) literal-vop <%box> ;
+: %box ( func -- vop ) src-vop <%box> ;
 
 VOP: %box-float
-: %box-float ( func -- vop ) literal-vop <%box-float> ;
+: %box-float ( func -- vop ) src-vop <%box-float> ;
 
 VOP: %box-double
-: %box-double ( [[ n func ]] -- vop ) literal-vop <%box-double> ;
+: %box-double ( [[ n func ]] -- vop ) src-vop <%box-double> ;
 
 VOP: %alien-invoke
-: %alien-invoke ( func -- vop ) literal-vop <%alien-invoke> ;
+: %alien-invoke ( func -- vop ) src-vop <%alien-invoke> ;
 
 VOP: %alien-global
-: %alien-global ( global -- vop ) literal-vop <%alien-global> ;
+: %alien-global ( global -- vop ) src-vop <%alien-global> ;

library/compiler/x86/alien.factor

@@ -6,10 +6,10 @@ kernel-internals lists math memory namespaces words ;
 
 M: %alien-invoke generate-node
     #! call a C function.
-    vop-literal uncons load-library compile-c-call ;
+    vop-in-1 uncons load-library compile-c-call ;
 
 M: %alien-global generate-node
-    vop-literal uncons load-library
+    vop-in-1 uncons load-library
     2dup dlsym EAX swap unit MOV 0 0 rel-dlsym ;
 
 M: %parameters generate-node
@@ -23,7 +23,7 @@ M: %parameter generate-node
 : UNBOX ( vop -- )
     #! An unboxer function takes a value from the data stack and
     #! converts it into a C value.
-    vop-literal cdr f compile-c-call ;
+    vop-in-1 cdr f compile-c-call ;
 
 M: %unbox generate-node
     #! C functions return integers in EAX.
@@ -49,7 +49,7 @@ M: %unbox-double generate-node
     #! A boxer function takes a C value as a parameter and
     #! converts into a Factor value, and pushes it on the data
     #! stack.
-    vop-literal f compile-c-call ;
+    vop-in-1 f compile-c-call ;
 
 M: %box generate-node
     #! C functions return integers in EAX.
@@ -78,4 +78,4 @@ M: %cleanup generate-node
     #! In the cdecl ABI, the caller must pop input parameters
     #! off the C stack. In stdcall, the callee does it, so
     #! this node is not used in that case.
-    vop-literal dup 0 = [ drop ] [ ESP swap ADD ] ifte ;
+    vop-in-1 dup 0 = [ drop ] [ ESP swap ADD ] ifte ;

library/compiler/x86/fixnum.factor

@@ -112,7 +112,7 @@ M: %fixnum-bitxor generate-node ( vop -- ) dest/src XOR ;
 
 M: %fixnum-bitnot generate-node ( vop -- )
     ! Negate the bits of the operand
-    vop-dest v>operand dup NOT
+    vop-out-1 v>operand dup NOT
     ! Mask off the low 3 bits to give a fixnum tag
     tag-mask XOR ;
 
@@ -122,7 +122,7 @@ M: %fixnum<< generate-node
     <label> "end" set
     ! make a copy
     ECX EAX MOV
-    vop-source
+    vop-in-1
     ! check for potential overflow
     1 over cell 8 * swap 1 - - shift ECX over ADD
     2 * 1 - ECX swap CMP
@@ -147,7 +147,7 @@ M: %fixnum<< generate-node
 
 M: %fixnum>> generate-node
     ! shift register
-    dup vop-dest v>operand dup rot vop-source SAR
+    dup vop-out-1 v>operand dup rot vop-in-1 SAR
     ! give it a fixnum tag
     tag-mask bitnot AND ;
 
@@ -155,7 +155,7 @@ M: %fixnum-sgn generate-node
     ! store 0 in EDX if EAX is >=0, otherwise store -1.
     CDQ
     ! give it a fixnum tag.
-    vop-dest v>operand tag-bits SHL ;
+    vop-out-1 v>operand tag-bits SHL ;
 
 : conditional ( dest cond -- )
     #! Compile this after a conditional jump to store f or t
@@ -170,7 +170,7 @@ M: %fixnum-sgn generate-node
     "end" get save-xt ; inline
 
 : fixnum-compare ( vop -- dest )
-    dup vop-dest v>operand dup rot vop-source v>operand CMP ;
+    dup vop-out-1 v>operand dup rot vop-in-1 v>operand CMP ;
 
 M: %fixnum< generate-node ( vop -- )
     fixnum-compare  \ JL  conditional ;
@@ -188,7 +188,7 @@ M: %eq? generate-node ( vop -- )
     fixnum-compare  \ JE  conditional ;
 
 : fixnum-branch ( vop -- label )
-    dup vop-dest v>operand over vop-source v>operand CMP
+    dup vop-in-2 v>operand over vop-in-1 v>operand CMP
     vop-label ;
 
 M: %jump-fixnum< generate-node ( vop -- )

library/compiler/x86/generator.factor

@@ -9,7 +9,7 @@ M: integer v>operand tag-bits shift ;
 M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
 
 : dest/src ( vop -- dest src )
-    dup vop-dest v>operand swap vop-source v>operand ;
+    dup vop-out-1 v>operand swap vop-in-1 v>operand ;
 
 ! Not used on x86
 M: %prologue generate-node drop ;
@@ -30,10 +30,10 @@ M: %jump generate-node ( vop -- )
     vop-label dup postpone-word JMP ;
 
 M: %jump-f generate-node ( vop -- )
-    dup vop-source v>operand f address CMP vop-label JE ;
+    dup vop-in-1 v>operand f address CMP vop-label JE ;
 
 M: %jump-t generate-node ( vop -- )
-    dup vop-source v>operand f address CMP vop-label JNE ;
+    dup vop-in-1 v>operand f address CMP vop-label JNE ;
 
 M: %return-to generate-node ( vop -- )
     0 PUSH vop-label absolute ;
@@ -42,19 +42,19 @@ M: %return generate-node ( vop -- )
     drop RET ;
 
 M: %untag generate-node ( vop -- )
-    vop-dest v>operand BIN: 111 bitnot AND ;
+    vop-out-1 v>operand BIN: 111 bitnot AND ;
 
 M: %tag-fixnum generate-node ( vop -- )
-    vop-dest v>operand 3 SHL ;
+    vop-out-1 v>operand 3 SHL ;
 
 M: %untag-fixnum generate-node ( vop -- )
-    vop-dest v>operand 3 SHR ;
+    vop-out-1 v>operand 3 SHR ;
 
 M: %dispatch generate-node ( vop -- )
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    vop-source v>operand
+    vop-in-1 v>operand
     ! Multiply by 4 to get a jump table offset
     dup 2 SHL
     ! Add to jump table base
@@ -68,10 +68,10 @@ M: %dispatch generate-node ( vop -- )
 
 M: %type generate-node ( vop -- )
     #! Intrinstic version of type primitive. It outputs an
-    #! UNBOXED value in vop-dest.
+    #! UNBOXED value in vop-out-1.
     <label> "f" set
     <label> "end" set
-    vop-dest v>operand
+    vop-out-1 v>operand
     ! Make a copy
     ECX over MOV
     ! Get the tag
@@ -96,7 +96,7 @@ M: %type generate-node ( vop -- )
 
 M: %arithmetic-type generate-node ( vop -- )
     #! This one works directly with the stack. It outputs an
-    #! UNBOXED value in vop-dest.
+    #! UNBOXED value in vop-out-1.
     0 <vreg> check-dest
     <label> "end" set
     ! Load top two stack values

library/compiler/x86/slots.factor

@@ -5,21 +5,21 @@ USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 M: %slot generate-node ( vop -- )
-    #! the untagged object is in vop-dest, the tagged slot
+    #! the untagged object is in vop-out-1, the tagged slot
-    #! number is in vop-source.
+    #! number is in vop-in-1.
     dest/src
     ! turn tagged fixnum slot # into an offset, multiple of 4
     dup 1 SHR
-    ! compute slot address in vop-dest
+    ! compute slot address in vop-out-1
     dupd ADD
-    ! load slot value in vop-dest
+    ! load slot value in vop-out-1
     dup unit MOV ;
 
 M: %fast-slot generate-node ( vop -- )
-    #! the tagged object is in vop-dest, the pointer offset is
+    #! the tagged object is in vop-out-1, the pointer offset is
-    #! in vop-literal. the offset already takes the type tag
+    #! in vop-in-1. the offset already takes the type tag
     #! into account, so its just one instruction to load.
-    dup vop-literal swap vop-dest v>operand tuck >r 2list r>
+    dup vop-in-1 swap vop-out-1 v>operand tuck >r 2list r>
     swap MOV ;
 
 : card-bits
@@ -36,34 +36,34 @@ M: %fast-slot generate-node ( vop -- )
     0 rel-cards ;
 
 M: %set-slot generate-node ( vop -- )
-    #! the untagged object is in vop-dest, the new value is in
+    #! the new value is vop-in-1, the object is vop-in-2, and
-    #! vop-source, the tagged slot number is in vop-literal.
+    #! the slot number is vop-in-3.
-    dup vop-literal v>operand over vop-dest v>operand
+    dup vop-in-3 v>operand over vop-in-2 v>operand
     ! turn tagged fixnum slot # into an offset, multiple of 4
     over 1 SHR
-    ! compute slot address in vop-literal
+    ! compute slot address in vop-in-2
     2dup ADD
     ! store new slot value
-    >r >r vop-source v>operand r> unit swap MOV r>
+    >r >r vop-in-1 v>operand r> unit swap MOV r>
     write-barrier ;
 
 M: %fast-set-slot generate-node ( vop -- )
-    #! the tagged object is in vop-dest, the new value is in
+    #! the new value is vop-in-1, the object is vop-in-2, and
-    #! vop-source, the pointer offset is in vop-literal. the
+    #! the slot offset is vop-in-3.
-    #! offset already takes the type tag into account, so its
+    #! the offset already takes the type tag into account, so
-    #! just one instruction to load.
+    #! it's just one instruction to load.
-    dup vop-literal over vop-dest v>operand
+    dup vop-in-3 over vop-in-2 v>operand
-    [ swap 2list swap vop-source v>operand MOV ] keep
+    [ swap 2list swap vop-in-1 v>operand MOV ] keep
     write-barrier ;
 
 : userenv@ ( n -- addr )
     cell * "userenv" f dlsym + ;
 
 M: %getenv generate-node ( vop -- )
-    dup vop-dest v>operand swap vop-literal
+    dup vop-out-1 v>operand swap vop-in-1
     [ userenv@ unit MOV ] keep 0 rel-userenv ;
 
 M: %setenv generate-node ( vop -- )
-    dup vop-literal
+    dup vop-in-2
-    [ userenv@ unit swap vop-source v>operand MOV ] keep
+    [ userenv@ unit swap vop-in-1 v>operand MOV ] keep
     0 rel-userenv ;

library/compiler/x86/stack.factor

@@ -18,38 +18,38 @@ memory sequences words ;
 : cs-op ( n -- op ) ECX swap reg-stack ;
 
 M: %peek-d generate-node ( vop -- )
-    dup vop-dest v>operand swap vop-literal ds-op MOV ;
+    dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
 
 M: %replace-d generate-node ( vop -- )
-    dup vop-source v>operand swap vop-literal ds-op swap MOV ;
+    dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
 
 M: %inc-d generate-node ( vop -- )
-    ESI swap vop-literal cell *
+    ESI swap vop-in-1 cell *
     dup 0 > [ ADD ] [ neg SUB ] ifte ;
 
 M: %immediate generate-node ( vop -- )
-    dup vop-dest v>operand swap vop-literal address MOV ;
+    dup vop-out-1 v>operand swap vop-in-1 address MOV ;
 
 : load-indirect ( dest literal -- )
     intern-literal unit MOV 0 0 rel-address ;
 
 M: %indirect generate-node ( vop -- )
     #! indirect load of a literal through a table
-    dup vop-dest v>operand swap vop-literal load-indirect ;
+    dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
 
 M: %peek-r generate-node ( vop -- )
-    ECX CS>  dup vop-dest v>operand swap vop-literal cs-op MOV ;
+    ECX CS>  dup vop-out-1 v>operand swap vop-in-1 cs-op MOV ;
 
 M: %dec-r generate-node ( vop -- )
     #! Can only follow a %peek-r
-    vop-literal ECX swap cell * SUB  ECX >CS ;
+    vop-in-1 ECX swap cell * SUB  ECX >CS ;
 
 M: %replace-r generate-node ( vop -- )
     #! Can only follow a %inc-r
-    dup vop-source v>operand swap vop-literal cs-op swap MOV
+    dup vop-in-2 v>operand swap vop-in-1 cs-op swap MOV
     ECX >CS ;
 
 M: %inc-r generate-node ( vop -- )
     #! Can only follow a %peek-r
     ECX CS>
-    vop-literal ECX swap cell * ADD ;
+    vop-in-1 ECX swap cell * ADD ;

library/generic/builtin.factor

@@ -25,7 +25,9 @@ builtin 50 "priority" set-word-prop
 builtin [ 2drop t ] "class<" set-word-prop
 
 : builtin-predicate ( class -- )
-    dup "predicate" word-prop car swap
+    dup "predicate" word-prop car
+    dup t "inline" set-word-prop
+    swap
     [
         \ type , "builtin-type" word-prop , \ eq? ,
     ] make-list

library/generic/tuple.factor

@@ -69,7 +69,7 @@ UNION: arrayed array tuple ;
     ] make-list define-compound ;
 
 : forget-tuple ( class -- )
-    dup forget "predicate" word-prop car forget ;
+    dup forget "predicate" word-prop car [ forget ] when* ;
 
 : check-shape ( word slots -- )
     #! If the new list of slots is different from the previous,

library/inference/branches.factor

@@ -73,33 +73,11 @@ sequences strings vectors words hashtables prettyprint ;
         terminate
     ] ifte* ;
 
-SYMBOL: cloned
+: deep-clone ( seq -- seq ) [ clone ] map ;
-
-GENERIC: (deep-clone)
-
-: deep-clone ( obj -- obj )
-    dup cloned get assq [ ] [
-        dup (deep-clone) [ swap cloned [ acons ] change ] keep
-    ] ?ifte ;
-
-M: tuple (deep-clone) ( obj -- obj )
-    #! Clone an object if it hasn't already been cloned in this
-    #! with-deep-clone scope.
-    clone dup <mirror> [ deep-clone ] nmap ;
-
-M: vector (deep-clone) ( seq -- seq )
-    #! Clone a sequence and each object it contains.
-    [ deep-clone ] map ;
-
-M: cons (deep-clone) ( cons -- cons )
-    uncons deep-clone >r deep-clone r> cons ;
-
-M: object (deep-clone) ( obj -- obj ) ;
 
 : copy-inference ( -- )
     #! We avoid cloning the same object more than once in order
     #! to preserve identity structure.
-    cloned off
     meta-r [ deep-clone ] change
     meta-d [ deep-clone ] change
     d-in [ deep-clone ] change
@@ -111,8 +89,6 @@ M: object (deep-clone) ( obj -- obj ) ;
     #! terminate was called.
     <namespace> [
         copy-inference
-        uncons deep-clone pull-tie
-        cloned off
         dup value-recursion recursive-state set
         literal-value dup infer-quot
         active? [
@@ -124,10 +100,6 @@ M: object (deep-clone) ( obj -- obj ) ;
     ] extend ;
 
 : (infer-branches) ( branchlist -- list )
-    #! The branchlist is a list of pairs: [[ value typeprop ]]
-    #! value is either a literal or computed instance; typeprop
-    #! is a pair [[ value class ]] indicating a type propagation
-    #! for the given branch.
     [
         [
             inferring-base-case get [
@@ -148,60 +120,23 @@ M: object (deep-clone) ( obj -- obj ) ;
     #! base case to this stack effect and try again.
     (infer-branches) dup unify-effects unify-dataflow ;
 
-: boolean-value? ( value -- ? )
-    #! Return if the value's boolean valuation is known.
-    value-class dup \ f = >r \ f class-and null = r> or ;
-
-: boolean-value ( value -- ? )
-    #! Only valid if boolean? returns true.
-    value-class \ f = not ;
-
-: static-ifte? ( value -- ? )
-    #! Is the outcome of this branch statically known?
-    dup value-safe? swap boolean-value? and ;
-
-: static-ifte ( true false -- )
-    #! If the branch taken is statically known, just infer
-    #! along that branch.
-    1 dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
-    >literal< infer-quot-value ;
-
 : infer-ifte ( true false -- )
     #! If branch taken is computed, infer along both paths and
     #! unify.
-    2list >r pop-d \ ifte r>
+    2list >r pop-d \ ifte r> infer-branches ;
-    pick [ POSTPONE: f general-t ] [ <class-tie> ] map-with
-    zip ( condition )
-    infer-branches ;
 
 \ ifte [
-    2 dataflow-drop, pop-d pop-d swap
+    2 dataflow-drop, pop-d pop-d swap infer-ifte
-    peek-d static-ifte? [
-        static-ifte
-    ] [
-        infer-ifte
-    ] ifte
 ] "infer" set-word-prop
 
 : vtable>list ( rstate vtable -- list  )
     [ swap <literal> ] map-with >list ;
 
-: <dispatch-index> ( value -- value )
-    value-literal-ties
-    0 recursive-state get <literal>
-    [ set-value-literal-ties ] keep ;
-
 USE: kernel-internals
 
 : infer-dispatch ( rstate vtable -- )
-    >r >r peek-d \ dispatch r> r>
+    >r >r pop-d \ dispatch r> r> vtable>list infer-branches ;
-    vtable>list
-    pop-d <dispatch-index>
-    over length [ <literal-tie> ] project-with
-    zip infer-branches ;
 
-\ dispatch [
+\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
-    pop-literal infer-dispatch
-] "infer" set-word-prop
 
 \ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

library/inference/partial-eval.factor

@@ -39,6 +39,7 @@ sequences words ;
 
 ! Could probably add more words here
 [
+    eq?
     car
     cdr
     cons
@@ -69,28 +70,6 @@ sequences words ;
     stateless
 ] each
 
-: eq-tie ( v1 v2 bool -- )
-    >r swap literal-value <literal-tie> general-t swons unit r>
-    set-value-class-ties ;
-
-: eq-ties ( v1 v2 bool -- )
-    #! If the boolean is true, the values are equal.
-    pick literal? [
-        eq-tie
-    ] [
-        over literal? [
-            swapd eq-tie
-        ] [
-            3drop
-        ] ifte
-    ] ifte ;
-
-\ eq? [
-    peek-d peek-next-d
-    \ eq? infer-eval
-    peek-d eq-ties
-] "infer" set-word-prop
-
 ! Partially-evaluated words need their stack effects to be
 ! entered by hand.
 \ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop

library/inference/ties.factor

@@ -1,48 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: kernel lists prettyprint ;
-
-! A tie is when a literal value determines the type or value of
-! a computed result. For example, in the following code, the
-! type of the top of the stack depends on the outcome of the
-! branch:
-!
-! dup cons? [ ... ] [ ... ] ifte
-!
-! In each branch, there is a different tie of the value to a
-! type.
-!
-! Another type of tie happends with generic dispatch.
-!
-! The return value of the 'type' primitive determines the type
-! of a value. The branch chosen in a dispatch determines the
-! numeric value used as the dispatch parameter. Because of a
-! pair of ties, this allows inferences such as the following
-! having a stack effect of [ [ cons ] [ object ] ]:
-!
-! GENERIC: car
-! M: cons car 0 slot ;
-!
-! The only branch that does not end with no-method pulls
-! a tie that sets the value's type to cons after two steps.
-
-! Formally, a tie is a tuple.
-
-GENERIC: pull-tie ( tie -- )
-
-TUPLE: class-tie value class ;
-M: class-tie pull-tie ( tie -- )
-    dup class-tie-class swap class-tie-value
-    2dup set-value-class
-    value-class-ties assoc pull-tie ;
-
-TUPLE: literal-tie value literal ;
-M: literal-tie pull-tie ( tie -- )
-    dup literal-tie-literal swap literal-tie-value
-    dup literal? [ 2dup set-literal-value ] when
-    value-literal-ties assoc pull-tie ;
-
-M: f pull-tie ( tie -- )
-    #! For convenience.
-    drop ;

library/inference/types.factor

@@ -1,30 +0,0 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: inference
-USING: generic interpreter kernel lists math namespaces words ;
-
-: type-value-map ( value -- )
-    num-types
-    [ tuck builtin-type <class-tie> cons ] project-with
-    [ cdr class-tie-class ] subset ;
-
-: infer-type ( -- )
-    f \ type dataflow, [
-        peek-d type-value-map >r
-        1 0 node-inputs
-        [ object ] consume-d
-        [ fixnum ] produce-d
-        r> peek-d set-value-literal-ties
-        1 0 node-outputs
-    ] bind ;
-
-: type-known? ( value -- ? )
-    dup value-safe? swap value-types cdr not and ;
-
-\ type [
-    peek-d type-known? [
-        1 dataflow-drop, pop-d value-types car apply-literal
-    ] [
-        infer-type
-    ] ifte
-] "infer" set-word-prop

library/inference/values.factor

@@ -7,7 +7,7 @@ GENERIC: value= ( literal value -- ? )
 GENERIC: value-class-and ( class value -- )
 GENERIC: safe-literal? ( value -- ? )
 
-TUPLE: value class recursion class-ties literal-ties safe? ;
+TUPLE: value class recursion safe? ;
 
 C: value ( recursion -- value )
     [ t swap set-value-safe? ] keep

library/test/compiler/intrinsics.factor

@@ -11,6 +11,9 @@ math-internals test words ;
 [ 3 ] [ 3 1 2 cons [ [ 0 set-slot ] keep ] compile-1 car ] unit-test
 [ 3 ] [ 3 1 2 [ cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
 [ 3 ] [ [ 3 1 2 cons [ 0 set-slot ] keep ] compile-1 car ] unit-test
+[ 3 ] [ 3 1 2 cons [ [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
+[ 3 ] [ 3 1 2 [ cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
+[ 3 ] [ [ 3 1 2 cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
 
 [ ] [ 1 [ drop ] compile-1 ] unit-test
 [ ] [ [ 1 drop ] compile-1 ] unit-test
@@ -158,3 +161,8 @@ math-internals test words ;
 
 [ 1 1 0 ] [ 1 1 [ arithmetic-type ] compile-1 ] unit-test
 [ 1.0 1.0 5 ] [ 1.0 1 [ arithmetic-type ] compile-1 ] unit-test
+
+[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
+[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
+[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test
+[ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] ifte ] compile-1 ] unit-test

library/test/inference.factor

@@ -146,24 +146,17 @@ SYMBOL: sym-test
 
 [ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test
 
-[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
-[ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test
 [ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test
-[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ swons ] infer old-effect ] unit-test
 [ [[ 1 2 ]] ] [ [ uncons ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ unit ] infer old-effect ] unit-test
 [ [[ 1 2 ]] ] [ [ unswons ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ last ] infer old-effect ] unit-test
-[ [[ 1 1 ]] ] [ [ peek ] infer old-effect ] unit-test
 [ [[ 1 1 ]] ] [ [ list? ] infer old-effect ] unit-test
 
-[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
+[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test
-[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
+[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test
-[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
-[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
-[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test
 
 [ [[ 2 1 ]] ] [ [ bitor ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ bitand ] infer old-effect ] unit-test
@@ -182,13 +175,6 @@ SYMBOL: sym-test
 [ [[ 2 1 ]] ] [ [ >= ] infer old-effect ] unit-test
 [ [[ 2 1 ]] ] [ [ number= ] infer old-effect ] unit-test
 
-[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test
-
-[ [[ 1 0 ]] ] [ [ >n ] infer old-effect ] unit-test
-[ [[ 0 1 ]] ] [ [ n> ] infer old-effect ] unit-test
-
-[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test
-
 : terminator-branch
     dup [
         car
@@ -198,15 +184,13 @@ SYMBOL: sym-test
 
 [ [[ 1 1 ]] ] [ [ terminator-branch ] infer old-effect ] unit-test
 
-[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test
-
 ! Type inference
 
-[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
-[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
-[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
-[ [ [ object ] [ general-t ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
+! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
-[ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+! [ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
 
 ! [ [ 5 car ] infer ] unit-test-fails
 
@@ -219,12 +203,12 @@ M: fixnum potential-hang dup [ potential-hang ] when ;
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
 ! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
 
-[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
+! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
-[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
+! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
-[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
+! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
-[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
+! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
 
-[ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test
+! [ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test
 
 TUPLE: funny-cons car cdr ;
 GENERIC: iterate
@@ -233,3 +217,18 @@ M: f iterate drop ;
 M: real iterate drop ;
 
 [ [[ 1 0 ]] ] [ [ iterate ] infer old-effect ] unit-test
+
+[ [[ 1 1 ]] ] [ [ str>number ] infer old-effect ] unit-test
+[ [[ 2 1 ]] ] [ [ = ] infer old-effect ] unit-test
+[ [[ 1 1 ]] ] [ [ get ] infer old-effect ] unit-test
+
+[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
+[ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test
+[ [[ 2 1 ]] ] [ [ append ] infer old-effect ] unit-test
+[ [[ 1 1 ]] ] [ [ peek ] infer old-effect ] unit-test
+
+[ [[ 1 1 ]] ] [ [ length ] infer old-effect ] unit-test
+[ [[ 1 1 ]] ] [ [ reverse ] infer old-effect ] unit-test
+[ [[ 2 1 ]] ] [ [ contains? ] infer old-effect ] unit-test
+[ [[ 2 1 ]] ] [ [ remove ] infer old-effect ] unit-test
+[ [[ 1 1 ]] ] [ [ prune ] infer old-effect ] unit-test

library/test/lists/lists.factor

@@ -44,7 +44,6 @@ USING: kernel lists sequences test ;
 [ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
 
 [ [ ]         ] [ 0   count ] unit-test
-[ [ ]         ] [ -10 count ] unit-test
 [ [ 0 1 2 3 ] ] [ 4   count ] unit-test
 
 [ f ] [ f 0 head ] unit-test