fix regression in basic block optimizer

library/bootstrap/primitives.factor

@@ -245,7 +245,10 @@ FORGET: set-stack-effect
 ! Okay, now we have primitives fleshed out. Bring up the generic
 ! word system.
 : builtin-predicate ( class predicate -- )
-    [ \ type , over types first , \ eq? , ] [ ] make
+    [
+        over types first dup
+        tag-mask < \ tag \ type ? , , \ eq? ,
+    ] [ ] make
     define-predicate ;
 
 : register-builtin ( class -- )

library/collections/hashtables.factor

@@ -140,6 +140,9 @@ IN: hashtables
 : hash-subset ( hash quot -- hash | quot: [[ k v ]] -- ? )
     >r hash>alist r> subset alist>hash ; inline
 
+: hash-subset-with ( obj hash quot -- hash )
+    swap [ with rot ] hash-subset 2nip ; inline
+
 M: hashtable clone ( hash -- hash )
     dup bucket-count <hashtable>
     over hash-size over set-hash-size

library/compiler/basic-blocks.factor

@@ -1,5 +1,5 @@
 IN: compiler-backend
-USING: hashtables kernel math namespaces sequences vectors ;
+USING: hashtables kernel lists math namespaces sequences vectors ;
 
 : (split-blocks) ( n linear -- )
     2dup length = [
@@ -117,7 +117,15 @@ M: %peek-r trim-dead* ( tail vop -- ) ?dead-peek ;
 : redundant-replace? ( vop -- ? )
     dup 0 vop-out swap 0 vop-in vreg-contents get hash = ;
 
+: forget-stack-loc ( loc -- )
+    #! Forget that any vregs hold this stack location.
+    vreg-contents [ [ cdr swap = not ] hash-subset-with ] change ;
+
 : remember-replace ( vop -- )
+    #! If a vreg claims to hold the stack location we are
+    #! writing to, we must forget this fact, since that stack
+    #! location no longer holds this value!
+    dup 0 vop-out forget-stack-loc
     dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ;
 
 : ?dead-replace ( tail vop -- )

library/inference/call-optimizers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: optimizer
-USING: errors generic hashtables inference kernel math
+USING: errors generic hashtables inference kernel lists math
 math-internals sequences vectors words ;
 
 ! A system for associating dataflow optimizers with words.

library/inference/known-words.factor

@@ -3,6 +3,42 @@ USING: alien assembler errors generic hashtables interpreter io
 io-internals kernel kernel-internals lists math math-internals
 memory parser sequences strings vectors words prettyprint ;
 
+! We transform calls to these words into 'branched' forms;
+! eg, there is no VOP for fixnum<=, only fixnum<= followed
+! by an #ifte, so if we have a 'bare' fixnum<= we add
+! [ t ] [ f ] ifte at the end.
+
+! This transformation really belongs in the optimizer, but it
+! is simpler to do it here.
+\ fixnum< [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
+\ fixnum< t "flushable" set-word-prop
+\ fixnum< t "foldable" set-word-prop
+
+\ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
+\ fixnum<= t "flushable" set-word-prop
+\ fixnum<= t "foldable" set-word-prop
+
+\ fixnum> [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
+\ fixnum> t "flushable" set-word-prop
+\ fixnum> t "foldable" set-word-prop
+
+\ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
+\ fixnum>= t "flushable" set-word-prop
+\ fixnum>= t "foldable" set-word-prop
+
+\ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ eq? t "flushable" set-word-prop
+\ eq? t "foldable" set-word-prop
+
+! : manual-branch ( word -- )
+!     dup "infer-effect" word-prop consume/produce
+!     [ [ t ] [ f ] ifte ] infer-quot ;
+! 
+! { fixnum<= fixnum< fixnum>= fixnum> eq? } [
+!     dup dup literalize [ manual-branch ] cons
+!     "infer" set-word-prop
+! ] each
+
 ! Primitive combinators
 \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
 
@@ -153,22 +189,6 @@ memory parser sequences strings vectors words prettyprint ;
 \ fixnum-shift t "flushable" set-word-prop
 \ fixnum-shift t "foldable" set-word-prop
 
-\ fixnum< [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
-\ fixnum< t "flushable" set-word-prop
-\ fixnum< t "foldable" set-word-prop
-
-\ fixnum<= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
-\ fixnum<= t "flushable" set-word-prop
-\ fixnum<= t "foldable" set-word-prop
-
-\ fixnum> [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
-\ fixnum> t "flushable" set-word-prop
-\ fixnum> t "foldable" set-word-prop
-
-\ fixnum>= [ [ fixnum fixnum ] [ boolean ] ] "infer-effect" set-word-prop
-\ fixnum>= t "flushable" set-word-prop
-\ fixnum>= t "foldable" set-word-prop
-
 \ bignum= [ [ bignum bignum ] [ boolean ] ] "infer-effect" set-word-prop
 \ bignum= t "flushable" set-word-prop
 \ bignum= t "foldable" set-word-prop
@@ -327,10 +347,6 @@ memory parser sequences strings vectors words prettyprint ;
 \ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
 \ compiled? [ [ word ] [ boolean ] ] "infer-effect" set-word-prop
 
-\ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ eq? t "flushable" set-word-prop
-\ eq? t "foldable" set-word-prop
-
 \ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop
 \ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop
 \ stat [ [ string ] [ general-list ] ] "infer-effect" set-word-prop

library/inference/split-nodes.factor

@@ -37,6 +37,13 @@ M: node split-node* ( node -- ) drop ;
     [ last-node 2dup swap post-inline set-node-successor ] keep
     split-node ;
 
+: inline-literals ( node literals -- node )
+    #! Make #push -> #return -> successor
+    over drop-inputs [
+        >r [ literalize ] map dataflow [ subst-node ] keep
+        r> set-node-successor
+    ] keep ;
+
 : split-branch ( node -- )
     dup node-successor over node-children
     [ >r clone-node r> subst-node ] each-with
@@ -51,10 +58,3 @@ M: #dispatch split-node* ( node -- )
 ! #label
 M: #label split-node* ( node -- )
     node-child split-node ;
-
-: inline-literals ( node literals -- node )
-    #! Make #push -> #return -> successor
-    over drop-inputs [
-        >r [ literalize ] map dataflow [ subst-node ] keep
-        r> set-node-successor
-    ] keep ;

library/test/compiler/intrinsics.factor

@@ -170,3 +170,8 @@ math-internals test words ;
 
 ! regression
 [ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-1 2nip ] unit-test
+
+! regression
+: blah over cons? [ "x" get >r 2cdr r> ] [ 2drop f f f ] ifte ; compiled
+
+[ f ] [ f "x" set [ 1 2 3 ] [ 1 3 2 ] blah drop 2car = ] unit-test