Inference transforms can now give up; remove elaboration phase since we'll do that while building CFG

unfinished/compiler/tree/builder/builder.factor

@@ -22,6 +22,11 @@ IN: compiler.tree.builder
     ] with-tree-builder nip
     unclip-last in-d>> ;
 
+: build-sub-tree ( #call quot -- nodes )
+    [ [ out-d>> ] [ in-d>> ] bi ] dip
+    build-tree-with
+    rot #copy suffix ;
+
 : (make-specializer) ( class picker -- quot )
     swap "predicate" word-prop append ;
 

unfinished/compiler/tree/elaboration/elaboration.factor

@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.elaboration
-
-: elaborate ( nodes -- nodes' ) ;

unfinished/compiler/tree/intrinsics/intrinsics.factor

@@ -1,6 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: kernel classes.tuple classes.tuple.private math arrays 
+byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
+: <immutable-tuple-boa> ( ... class -- tuple )
+    "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
+
+: (tuple) ( layout -- tuple )
+    "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } define-primitive
+\ (tuple) make-flushable
+
+: (array) ( n -- array )
+    "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } define-primitive
+\ (array) make-flushable
+
+: (byte-array) ( n -- byte-array )
+    "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } define-primitive
+\ (byte-array) make-flushable

unfinished/compiler/tree/loop/detection/detection.factor

@@ -22,7 +22,7 @@ IN: compiler.tree.loop.detection
 
 SYMBOL: loop-heights
 SYMBOL: loop-calls
-SYMBOL: label-stack
+SYMBOL: loop-stack
 SYMBOL: work-list
 
 GENERIC: collect-loop-info* ( tail? node -- )
@@ -34,14 +34,14 @@ GENERIC: collect-loop-info* ( tail? node -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
 : remember-loop-info ( label -- )
-    label-stack get length swap loop-heights get set-at ;
+    loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
         [
             label>>
-            [ label-stack [ swap suffix ] change ]
+            [ loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -50,7 +50,7 @@ M: #recursive collect-loop-info*
     ] with-scope ;
 
 : current-loop-nesting ( label -- labels )
-    label-stack get swap loop-heights get at tail ;
+    loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
     work-list get push-front ;
@@ -69,7 +69,7 @@ M: #dispatch collect-loop-info*
 M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
-    { } label-stack set
+    { } loop-stack set
     H{ } clone loop-calls set
     H{ } clone loop-heights set
     <hashed-dlist> work-list set

unfinished/compiler/tree/optimizer/optimizer.factor

@@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
-compiler.tree.loop-detection
+compiler.tree.loop.detection
 compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
@@ -16,11 +16,11 @@ IN: compiler.tree.optimizer
     normalize
     propagate
     cleanup
+    detect-loops
+    invert-loops
+    fuse-branches
     escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
-    strength-reduce
+    strength-reduce ;
-    detect-loops
-    fuse-branches
-    elaborate ;

unfinished/compiler/tree/propagation/inlining/inlining.factor

@@ -18,10 +18,7 @@ M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: quotation splicing-nodes
-    [ [ out-d>> ] [ in-d>> ] bi ] dip
+    build-sub-tree normalize ;
-    build-tree-with
-    rot #copy suffix
-    normalize ;
 
 : propagate-body ( #call -- )
     body>> (propagate) ;

unfinished/stack-checker/known-words/known-words.factor

@@ -165,24 +165,27 @@ M: object infer-call*
 { call execute dispatch load-locals get-local drop-locals }
 [ t "no-compile" set-word-prop ] each
 
+SYMBOL: +primitive+
+
 : non-inline-word ( word -- )
     dup +called+ depends-on
     {
         { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
         { [ dup +special+ word-prop ] [ infer-special ] }
-        { [ dup primitive? ] [ infer-primitive ] }
+        { [ dup +primitive+ word-prop ] [ infer-primitive ] }
         { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
         { [ dup recursive-label ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
 
 : define-primitive ( word inputs outputs -- )
+    [ 2drop t +primitive+ set-word-prop ]
     [ drop "input-classes" set-word-prop ]
     [ nip "default-output-classes" set-word-prop ]
-    3bi ;
+    3tri ;
 
 ! Stack effects for all primitives
 \ fixnum< { fixnum fixnum } { object } define-primitive

unfinished/stack-checker/transforms/transforms.factor

@@ -11,31 +11,45 @@ IN: stack-checker.transforms
 SYMBOL: +transform-quot+
 SYMBOL: +transform-n+
 
-: (apply-transform) ( quot n -- newquot )
+: give-up-transform ( word -- )
-    dup zero? [
+    dup recursive-label
-        drop recursive-state get 1array
+    [ call-recursive-word ]
-    ] [
+    [ dup infer-word apply-word/effect ]
-        consume-d
+    if ;
-        [ #drop, ]
+
-        [ [ literal value>> ] map ]
+: ((apply-transform)) ( word quot stack -- )
-        [ first literal recursion>> ] tri prefix
+    swap with-datastack first2
-    ] if
+    dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
-    swap with-datastack ;
+    inline
+
+: (apply-transform) ( word quot n -- )
+    consume-d dup [ known literal? ] all? [
+        dup empty? [
+            drop recursive-state get 1array
+        ] [
+            [ #drop, ]
+            [ [ literal value>> ] map ]
+            [ first literal recursion>> ] tri prefix
+        ] if
+        ((apply-transform))
+    ] [ 2drop give-up-transform ] if ;
 
 : apply-transform ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ +transform-quot+ word-prop ]
         [ +transform-n+ word-prop ]
-        bi (apply-transform)
+        tri
-        first2 swap infer-quot
+        (apply-transform)
     ] bi ;
 
 : apply-macro ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ "macro" word-prop ]
         [ "declared-effect" word-prop in>> length ]
-        bi (apply-transform)
+        tri
-        first2 swap infer-quot
+        (apply-transform)
     ] bi ;
 
 : define-transform ( word quot n -- )
@@ -66,20 +80,80 @@ SYMBOL: +transform-n+
 
 \ spread [ spread>quot ] 1 define-transform
 
+\ (call-next-method) [
+    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
+
+! Constructors
 \ boa [
     dup tuple-class? [
         dup +inlined+ depends-on
         [ "boa-check" word-prop ]
         [ tuple-layout '[ , <tuple-boa> ] ]
         bi append
-    ] [
+    ] [ drop f ] if
-        \ boa \ no-method boa time-bomb
-    ] if
 ] 1 define-transform
 
-\ (call-next-method) [
+\ new [
-    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+    dup tuple-class? [
-] 2 define-transform
+        dup +inlined+ depends-on
+        dup all-slots rest-slice ! delegate slot
+        [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
+    ] [ drop f ] if
+] 1 define-transform
+
+! Membership testing
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+    #! Can we use a fast byte array test here?
+    {
+        { [ dup length 8 < ] [ f ] }
+        { [ dup [ integer? not ] contains? ] [ f ] }
+        { [ dup [ 0 < ] contains? ] [ f ] }
+        { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+    bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+    dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+    [
+        [ drop ] % ! drop the sequence itself; we don't use it at run time
+        bit-member-seq ,
+        [
+            {
+                { [ over fixnum? ] [ ?nth 1 eq? ] }
+                { [ over bignum? ] [ ?nth 1 eq? ] }
+                { [ over exact-float? ] [ ?nth 1 eq? ] }
+                [ 2drop f ]
+            } cond
+        ] %
+    ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+    dup bit-member? [
+        bit-member-quot
+    ] [
+        [ literalize [ t ] ] { } map>assoc
+        [ drop f ] suffix [ nip case ] curry
+    ] if ;
+
+\ member? [
+    dup sequence? [ member-quot ] [ drop f ] if
+] 1 define-transform
+
+: memq-quot ( seq -- newquot )
+    [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+    [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? [
+    dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-transform
 
 ! Deprecated
 \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform