Alien unboxing

core/compiler/test/templates-early.factor

@@ -4,6 +4,8 @@ USING: compiler generator generator.registers
 generator.registers.private tools.test namespaces sequences
 words kernel math effects ;
 
+: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+
 [
     [ ] [ init-templates ] unit-test
     
@@ -58,8 +60,6 @@ words kernel math effects ;
         { +input+ { { f "x" } } }
     } clone [
         [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
-        [ ] [ 1 0 ensure-vregs ] unit-test
-        ! [ t ] [ +input+ get phantom-d get compatible? ] unit-test
         [ ] [ finalize-contents ] unit-test
         [ ] [ [ template-inputs ] { } make drop ] unit-test
     ] bind
@@ -119,12 +119,14 @@ SYMBOL: template-chosen
 
     ! This is not empty since a load instruction is emitted
     [ f ] [
-        [ { { f "x" } } fast-input ] { } make empty?
+        [ { { f "x" } } +input+ set load-inputs ] { } make
+        empty?
     ] unit-test
 
     ! This is empty since we already loaded the value
     [ t ] [
-        [ { { f "x" } } fast-input ] { } make empty?
+        [ { { f "x" } } +input+ set load-inputs ] { } make
+        empty?
     ] unit-test
 
     ! This is empty since we didn't change the stack

core/cpu/architecture/architecture.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic kernel kernel.private math memory
 namespaces sequences layouts system hashtables classes alien
-byte-arrays bit-arrays float-arrays combinators words
+byte-arrays bit-arrays float-arrays combinators words ;
-inference.dataflow ;
 IN: cpu.architecture
 
 SYMBOL: compiler-backend
@@ -153,8 +152,6 @@ M: integer v>operand tag-bits get shift ;
 
 M: f v>operand drop \ f tag-number ;
 
-M: value v>operand value-literal ;
-
 M: object load-literal v>operand load-indirect ;
 
 PREDICATE: integer small-slot cells small-enough? ;
@@ -189,7 +186,7 @@ HOOK: %unbox-alien compiler-backend ( dst src -- )
 
 HOOK: %unbox-f compiler-backend ( dst src -- )
 
-HOOK: %unbox-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
 
 HOOK: %box-alien compiler-backend ( dst src -- )
 

core/cpu/ppc/architecture/architecture.factor

@@ -269,7 +269,7 @@ M: ppc-backend %alien-invoke ( symbol dll -- )
     11 %load-dlsym (%call) ;
 
 M: ppc-backend %alien-callback ( quot -- )
-    0 <int-vreg> load-literal "c_to_factor" f %alien-invoke ;
+    3 load-indirect "c_to_factor" f %alien-invoke ;
 
 M: ppc-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
@@ -324,7 +324,7 @@ M: ppc-backend %unbox-alien ( dst src -- )
 M: ppc-backend %unbox-f ( dst src -- )
     drop 0 swap v>operand LI ;
 
-M: ppc-backend %unbox-c-ptr ( dst src -- )
+M: ppc-backend %unbox-any-c-ptr ( dst src -- )
     "is-f" define-label
     "is-alien" define-label
     "end" define-label

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -15,7 +15,7 @@ IN: cpu.ppc.intrinsics
     "val" operand
     "obj" operand
     "n" get cells
-    "obj" operand-tag - ;
+    "obj" get operand-tag - ;
 
 : %slot-literal-any-tag
     "obj" operand "scratch" operand %untag
@@ -58,7 +58,7 @@ IN: cpu.ppc.intrinsics
     "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
 
 : %write-barrier ( -- )
-    "val" operand-immediate? "obj" get fresh-object? or [
+    "val" get operand-immediate? "obj" get fresh-object? or [
         "obj" operand "scratch" operand card-bits SRWI
         "val" operand load-cards-offset
         "scratch" operand dup "val" operand ADD
@@ -674,8 +674,7 @@ define-alien-integer-intrinsics
         { unboxed-c-ptr "alien" simple-c-ptr }
         { f "offset" fixnum }
     } }
-    ! should be unboxed-alien
+    { +scratch+ { { unboxed-alien "output" } } }
-    { +scratch+ { { unboxed-c-ptr "output" } } }
     { +output+ { "output" } }
     { +clobber+ { "offset" } }
 } define-intrinsic

core/effects/effects.factor

@@ -51,3 +51,18 @@ M: integer (stack-picture) drop "object" ;
 
 M: effect clone
     [ effect-in clone ] keep effect-out clone <effect> ;
+
+: split-shuffle ( stack shuffle -- stack1 stack2 )
+    effect-in length swap cut* ;
+
+: load-shuffle ( stack shuffle -- )
+    effect-in [ set ] 2each ;
+
+: shuffled-values ( shuffle -- values )
+    effect-out [ get ] map ;
+
+: shuffle* ( stack shuffle -- newstack )
+    [ [ load-shuffle ] keep shuffled-values ] with-scope ;
+
+: shuffle ( stack shuffle -- newstack )
+    [ split-shuffle ] keep shuffle* append ;

core/generator/generator.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes combinators cpu.architecture
 effects generator.fixup generator.registers generic hashtables
-inference inference.backend inference.dataflow inference.stack
+inference inference.backend inference.dataflow io kernel
-io kernel kernel.private layouts math namespaces optimizer
+kernel.private layouts math namespaces optimizer prettyprint
-prettyprint quotations sequences system threads words ;
+quotations sequences system threads words ;
 IN: generator
 
 SYMBOL: compiled-xts
@@ -246,10 +246,8 @@ M: #dispatch generate-node
 : define-if-intrinsic ( word quot inputs -- )
     2array 1array define-if-intrinsics ;
 
-: do-intrinsic ( pair -- ) first2 with-template ;
-
 : do-if-intrinsic ( #call pair -- next )
-    <label> [ swap do-intrinsic ] keep
+    <label> [ swap do-template ] keep
     >r node-successor r> generate-if
     node-successor ;
 
@@ -264,11 +262,12 @@ M: #dispatch generate-node
     ] if ;
 
 M: #call generate-node
+    dup node-input-classes set-operand-classes
     dup find-if-intrinsic [
         do-if-intrinsic
     ] [
         dup find-intrinsic [
-            do-intrinsic iterate-next
+            do-template iterate-next
         ] [
             node-param generate-call
         ] ?if
@@ -278,10 +277,9 @@ M: #call generate-node
 M: #call-label generate-node node-param generate-call ;
 
 ! #push
-UNION: immediate fixnum POSTPONE: f ;
-
 M: #push generate-node
-    node-out-d [ phantom-push ] each iterate-next ;
+    node-out-d [ value-literal <constant> phantom-push ] each
+    iterate-next ;
 
 ! #shuffle
 M: #shuffle generate-node
@@ -313,6 +311,3 @@ M: #return generate-node drop end-basic-block %return f ;
 : alien-offset 3 cells object tag-number - ;
 : tuple-class-offset 2 cells tuple tag-number - ;
 : class-hash-offset cell object tag-number - ;
-
-: operand-immediate? ( operand -- ? )
-    operand-class immediate class< ;

core/generator/registers/registers.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes classes.private combinators
-cpu.architecture generator.fixup generic hashtables
+cpu.architecture generator.fixup hashtables kernel layouts math
-inference.dataflow inference.stack kernel kernel.private layouts
+namespaces quotations sequences system vectors words effects
-math memory namespaces quotations sequences system vectors words
+alien byte-arrays bit-arrays float-arrays ;
-effects ;
 IN: generator.registers
 
 SYMBOL: +input+
@@ -13,83 +12,205 @@ SYMBOL: +scratch+
 SYMBOL: +clobber+
 SYMBOL: known-tag
 
+! Register classes
+TUPLE: int-regs ;
+
+TUPLE: float-regs size ;
+
+<PRIVATE
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-vregs* ( obj -- )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+MIXIN: value
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+    operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-vregs* drop ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
 ! A scratch register for computations
 TUPLE: vreg n ;
 
 : <vreg> ( n reg-class -- vreg )
     { set-vreg-n set-delegate } vreg construct ;
 
-! Register classes
+M: vreg v>operand dup vreg-n swap vregs nth ;
-TUPLE: int-regs ;
+M: vreg live-vregs* , ;
-TUPLE: float-regs size ;
 
-: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+INSTANCE: vreg value
-: <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
 
 ! Temporary register for stack shuffling
 TUPLE: temp-reg ;
 
 : temp-reg T{ temp-reg T{ int-regs } } ;
 
-M: vreg v>operand dup vreg-n swap vregs nth ;
+M: temp-reg move-spec drop f ;
 
+INSTANCE: temp-reg value
+
+! A data stack location.
+TUPLE: ds-loc n class ;
+
+: <ds-loc> { set-ds-loc-n } ds-loc construct ;
+
+M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc operand-class* ds-loc-class ;
+M: ds-loc set-operand-class set-ds-loc-class ;
+
+! A retain stack location.
+TUPLE: rs-loc n class ;
+
+: <rs-loc> { set-rs-loc-n } rs-loc construct ;
+
+M: rs-loc operand-class* rs-loc-class ;
+M: rs-loc set-operand-class set-rs-loc-class ;
+
+UNION: loc ds-loc rs-loc ;
+
+M: loc move-spec drop loc ;
+M: loc live-loc? = not ;
+
+INSTANCE: loc value
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
 TUPLE: cached loc vreg ;
 
 C: <cached> cached
 
-! A data stack location.
+M: cached set-operand-class cached-vreg set-operand-class ;
-TUPLE: ds-loc n ;
+M: cached operand-class* cached-vreg operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-loc? cached-loc live-loc? ;
+M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached lazy-store
+    2dup cached-loc = [ 2drop ] [ cached-vreg %move ] if ;
+M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
 
-C: <ds-loc> ds-loc
+INSTANCE: cached value
 
-! A retain stack location.
+! A tagged pointer
-TUPLE: rs-loc n ;
+TUPLE: tagged vreg class ;
 
-C: <rs-loc> rs-loc
+: <tagged> ( vreg -- tagged )
+    { set-tagged-vreg } tagged construct ;
+
+M: tagged v>operand tagged-vreg v>operand ;
+M: tagged set-operand-class set-tagged-class ;
+M: tagged operand-class* tagged-class ;
+M: tagged move-spec drop f ;
+M: tagged live-vregs* tagged-vreg , ;
+
+INSTANCE: tagged value
 
 ! Unboxed alien pointers
 TUPLE: unboxed-alien vreg ;
 C: <unboxed-alien> unboxed-alien
 M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+
+INSTANCE: unboxed-alien value
 
 TUPLE: unboxed-byte-array vreg ;
 C: <unboxed-byte-array> unboxed-byte-array
 M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array operand-class* drop simple-c-ptr ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+
+INSTANCE: unboxed-byte-array value
 
 TUPLE: unboxed-f vreg ;
 C: <unboxed-f> unboxed-f
 M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+
+INSTANCE: unboxed-f value
 
 TUPLE: unboxed-c-ptr vreg ;
 C: <unboxed-c-ptr> unboxed-c-ptr
 M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr operand-class* drop simple-c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+
+INSTANCE: unboxed-c-ptr value
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+M: constant operand-class* constant-value class ;
+M: constant move-spec class ;
+
+INSTANCE: constant value
 
 <PRIVATE
 
-UNION: loc ds-loc rs-loc ;
-
 ! Moving values between locations and registers
-GENERIC: move-spec ( obj -- spec )
+: %move-bug "Bug in generator.registers" throw ;
 
-M: unboxed-alien move-spec class ;
+: %unbox-c-ptr ( dst src -- )
-M: unboxed-byte-array move-spec class ;
+    dup operand-class {
-M: unboxed-f move-spec class ;
+        { [ dup \ f class< ] [ drop %unbox-f ] }
-M: unboxed-c-ptr move-spec class ;
+        { [ dup simple-alien class< ] [ drop %unbox-alien ] }
-M: int-regs move-spec drop f ;
+        { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
-M: float-regs move-spec drop float ;
+        { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
-M: value move-spec class ;
+        { [ dup float-array class< ] [ drop %unbox-byte-array ] }
-M: cached move-spec drop cached ;
+        { [ t ] [ drop %unbox-any-c-ptr ] }
-M: loc move-spec drop loc ;
+    } cond ; inline
-M: f move-spec drop loc ;
+
+: %move-via-temp ( dst src -- )
+    #! For many transfers, such as loc to unboxed-alien, we
+    #! don't have an intrinsic, so we transfer the source to
+    #! temp then temp to the destination.
+    temp-reg over %move
+    operand-class temp-reg
+    { set-operand-class set-tagged-vreg } tagged construct
+    %move ;
 
 : %move ( dst src -- )
     2dup [ move-spec ] 2apply 2array {
-        { { f f } [ "Bug in generator.registers %move" throw ] }
+        { { f f } [ %move-bug ] }
-        { { f value } [ value-literal swap load-literal ] }
+        { { f unboxed-c-ptr } [ %move-bug ] }
+        { { f unboxed-byte-array } [ %move-bug ] }
+
+        { { f constant } [ constant-value swap load-literal ] }
 
         { { f float } [ %box-float ] }
-        ! { { f unboxed-alien } [ %box-alien ] }
+        { { f unboxed-alien } [ %box-alien ] }
-        { { f unboxed-c-ptr } [ %box-alien ] }
         { { f loc } [ %peek ] }
 
         { { float f } [ %unbox-float ] }
@@ -99,7 +220,7 @@ M: f move-spec drop loc ;
         { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
         { { loc f } [ swap %replace ] }
 
-        [ drop temp-reg swap %move temp-reg %move ]
+        [ drop %move-via-temp ]
     } case ;
 
 ! A compile-time stack
@@ -176,37 +297,20 @@ M: phantom-stack cut-phantom
 : phantom-append ( seq stack -- )
     over length over adjust-phantom push-all ;
 
+: add-locs ( n phantom -- )
+    2dup length <= [
+        2drop
+    ] [
+        [ phantom-locs ] keep
+        [ length head-slice* ] keep
+        [ append >vector ] keep
+        delegate set-delegate
+    ] if ;
+
 : phantom-input ( n phantom -- seq )
-    [
+    2dup add-locs
-        2dup length <= [
+    2dup cut-phantom
-            cut-phantom
+    >r >r neg r> adjust-phantom r> ;
-        ] [
-            [ phantom-locs ] keep
-            [ length head-slice* ] keep
-            [ append ] keep
-            delete-all
-        ] if
-    ] 2keep >r neg r> adjust-phantom ;
-
-PRIVATE>
-
-: phantom-push ( obj -- )
-    1 phantom-d get adjust-phantom
-    phantom-d get push ;
-
-: phantom-shuffle ( shuffle -- )
-    [ effect-in length phantom-d get phantom-input ] keep
-    shuffle* phantom-d get phantom-append ;
-
-: phantom->r ( n -- )
-    phantom-d get phantom-input
-    phantom-r get phantom-append ;
-
-: phantom-r> ( n -- )
-    phantom-r get phantom-input
-    phantom-d get phantom-append ;
-
-<PRIVATE
 
 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 
@@ -214,26 +318,9 @@ PRIVATE>
 
 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
 
-! Phantom stacks hold values, locs, and vregs
-GENERIC: live-vregs* ( obj -- )
-
-M: cached live-vregs* cached-vreg live-vregs* ;
-M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
-M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
-M: unboxed-f live-vregs* unboxed-f-vreg , ;
-M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
-M: vreg live-vregs* , ;
-M: object live-vregs* drop ;
-
 : live-vregs ( -- seq )
     [ [ [ live-vregs* ] each ] each-phantom ] { } make ;
 
-GENERIC: live-loc? ( actual current -- ? )
-
-M: cached live-loc? cached-loc live-loc? ;
-M: loc live-loc? = not ;
-M: object live-loc? 2drop f ;
-
 : (live-locs) ( phantom -- seq )
     #! Discard locs which haven't moved
     dup phantom-locs* swap 2array flip
@@ -248,10 +335,51 @@ M: object live-loc? 2drop f ;
 SYMBOL: fresh-objects
 
 ! Computing free registers and initializing allocator
+: reg-spec>class ( spec -- class )
+    float eq?
+    T{ float-regs f 8 } T{ int-regs } ? ;
+
 : free-vregs ( reg-class -- seq )
     #! Free vregs in a given register class
     \ free-vregs get at ;
 
+: alloc-vreg ( spec -- reg )
+    dup reg-spec>class free-vregs pop swap {
+        { f [ <tagged> ] }
+        { unboxed-alien [ <unboxed-alien> ] }
+        { unboxed-byte-array [ <unboxed-byte-array> ] }
+        { unboxed-f [ <unboxed-f> ] }
+        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+        [ drop ]
+    } case ;
+
+: compatible? ( value spec -- ? )
+    >r move-spec r> {
+        { [ 2dup = ] [ t ] }
+        { [ dup unboxed-c-ptr eq? ] [
+            over { unboxed-byte-array unboxed-alien } member?
+        ] }
+        { [ t ] [ f ] }
+    } cond 2nip ;
+
+: allocation ( value spec -- reg-class )
+    {
+        { [ dup quotation? ] [ 2drop f ] }
+        { [ 2dup compatible? ] [ 2drop f ] }
+        { [ t ] [ nip reg-spec>class ] }
+    } cond ;
+
+: alloc-vreg-for ( value spec -- vreg )
+    swap operand-class swap alloc-vreg
+    dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
+
+M: value (lazy-load)
+    2dup allocation [
+        dupd alloc-vreg-for dup rot %move
+    ] [
+        drop
+    ] if ;
+
 : (compute-free-vregs) ( used class -- vector )
     #! Find all vregs in 'class' which are not in 'used'.
     [ vregs length reverse ] keep
@@ -266,55 +394,14 @@ SYMBOL: fresh-objects
     \ free-vregs set
     drop ;
 
-: reg-spec>class ( spec -- class )
-    float eq?
-    T{ float-regs f 8 } T{ int-regs } ? ;
-
-! Copying vregs to stacks
-: alloc-vreg ( spec -- reg )
-    dup reg-spec>class free-vregs pop swap {
-        { unboxed-alien [ <unboxed-alien> ] }
-        { unboxed-byte-array [ <unboxed-byte-array> ] }
-        { unboxed-f [ <unboxed-f> ] }
-        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
-        [ drop ]
-    } case ;
-
-: allocation ( value spec -- reg-class )
-    dup quotation? [
-        2drop f
-    ] [
-        dup rot move-spec = [
-            drop f
-        ] [
-            reg-spec>class
-        ] if
-    ] if ;
-
-GENERIC# (lazy-load) 1 ( value spec -- value )
-
-M: cached (lazy-load)
-    >r cached-vreg r> (lazy-load) ;
-
-M: object (lazy-load)
-    2dup allocation [ alloc-vreg dup rot %move ] [ drop ] if ;
-
-GENERIC: lazy-store ( dst src -- )
-
 M: loc lazy-store
-    2dup = [ 2drop ] [ \ live-locs get at %move ] if ;
+    2dup = [ 2drop ] [ "live-locs" get at %move ] if ;
-
-M: cached lazy-store
-    2dup cached-loc = [ 2drop ] [ cached-vreg %move ] if ;
-
-M: object lazy-store
-    2drop ;
 
 : do-shuffle ( hash -- )
     dup assoc-empty? [
         drop
     ] [
-        \ live-locs set
+        "live-locs" set
         [ lazy-store ] each-loc
     ] if ;
 
@@ -323,12 +410,6 @@ M: object lazy-store
     #! at once
     [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
 
-GENERIC: minimal-ds-loc* ( min obj -- min )
-
-M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
-M: ds-loc minimal-ds-loc* ds-loc-n min ;
-M: object minimal-ds-loc* drop ;
-
 : minimal-ds-loc ( phantom -- n )
     #! When shuffling more values than can fit in registers, we
     #! need to find an area on the data stack which isn't in
@@ -380,60 +461,42 @@ M: object minimal-ds-loc* drop ;
     "simple_gc" f %alien-invoke ;
 
 ! Loading stacks to vregs
-: free-vregs# ( -- int# float# )
-    T{ int-regs } T{ float-regs f 8 } 
-    [ free-vregs length ] 2apply ;
-
 : free-vregs? ( int# float# -- ? )
-    free-vregs# swapd <= >r <= r> and ;
+    T{ float-regs f 8 } free-vregs length <
-
+    >r T{ int-regs } free-vregs length < r> and ;
-: ensure-vregs ( int# float# -- )
-    compute-free-vregs free-vregs?
-    [ finalize-contents compute-free-vregs ] unless ;
 
 : phantom&spec ( phantom spec -- phantom' spec' )
-    0 <column>
     [ length f pad-left ] keep
     [ <reversed> ] 2apply ; inline
 
 : phantom&spec-agree? ( phantom spec quot -- ? )
     >r phantom&spec r> 2all? ; inline
 
-: split-template ( input -- slow fast )
-    phantom-d get
-    2dup [ length ] 2apply <=
-    [ drop { } swap ] [ length swap cut* ] if ;
-
 : vreg-substitution ( value vreg -- pair )
     dupd <cached> 2array ;
 
 : substitute-vreg? ( old new -- ? )
     #! We don't substitute locs for float or alien vregs,
     #! since in those cases the boxing overhead might kill us.
-    cached-vreg {
+    cached-vreg tagged? >r loc? r> and ;
-        { [ dup vreg? not ] [ f ] }
-        { [ dup delegate int-regs? not ] [ f ] }
-        { [ over loc? not ] [ f ] }
-        { [ t ] [ t ] }
-    } cond 2nip ;
 
 : substitute-vregs ( values vregs -- )
     [ vreg-substitution ] 2map
     [ substitute-vreg? ] assoc-subset >hashtable
     [ swap substitute ] curry each-phantom ;
 
+: set-operand ( value var -- )
+    >r dup constant? [ constant-value ] when r> set ;
+
 : lazy-load ( values template -- )
     #! Set operand vars here.
-    2dup [ first (lazy-load) ] 2map dup rot
+    2dup [ first (lazy-load) ] 2map
-    [ >r dup value? [ value-literal ] when r> second set ] 2each
+    dup rot [ second set-operand ] 2each
     substitute-vregs ;
 
-: fast-input ( template -- )
+: load-inputs ( -- )
-    dup empty? [
+    +input+ get dup length phantom-d get phantom-input
-        drop
+    swap lazy-load ;
-    ] [
-        dup length phantom-d get phantom-input swap lazy-load
-    ] if ;
 
 : output-vregs ( -- seq seq )
     +output+ +clobber+ [ get [ get ] map ] 2apply ;
@@ -446,9 +509,6 @@ M: object minimal-ds-loc* drop ;
 : outputs-clash? ( -- ? )
     output-vregs append clash? ;
 
-: slow-input ( template -- )
-    outputs-clash? [ finalize-contents ] when fast-input ;
-
 : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
 
 : count-input-vregs ( phantom spec -- )
@@ -477,14 +537,12 @@ M: object minimal-ds-loc* drop ;
     +input+ get { } +scratch+ get guess-vregs ;
 
 : template-inputs ( -- )
-    ! Ensure we have enough to hold any new stack elements we
+    ! Load input values into registers
-    ! will read (if any), and scratch.
+    load-inputs
-    guess-template-vregs ensure-vregs
+    ! Allocate scratch registers
-    ! Split the template into available (fast) parts and those
+    alloc-scratch
-    ! that require allocating registers and reading the stack
+    ! If outputs clash, we write values back to the stack
-    +input+ get split-template fast-input slow-input
+    outputs-clash? [ finalize-contents ] when ;
-    ! Finally allocate scratch registers
-    alloc-scratch ;
 
 : template-outputs ( -- )
     +output+ get [ get ] map phantom-d get phantom-append ;
@@ -496,16 +554,12 @@ M: object minimal-ds-loc* drop ;
     #! spec is not a quotation, its a reg-class, in which case
     #! the value is always good.
     dup quotation? [
-        over value?
+        over constant?
-        [ >r value-literal r> call ] [ 2drop f ] if
+        [ >r constant-value r> call ] [ 2drop f ] if
     ] [
         2drop t
     ] if ;
 
-: template-specs-match? ( -- ? )
-    phantom-d get +input+ get
-    [ value-matches? ] phantom&spec-agree? ;
-
 : class-tag ( class -- tag/f )
     dup hi-tag class< [
         drop object tag-number
@@ -514,32 +568,42 @@ M: object minimal-ds-loc* drop ;
         dup length 1 = [ first tag-number ] [ drop f ] if
     ] if ;
 
-: class-match? ( actual expected -- ? )
+: class-matches? ( actual expected -- ? )
     {
         { f [ drop t ] }
         { known-tag [ class-tag >boolean ] }
         [ class< ]
     } case ;
 
-: template-classes-match? ( -- ? )
+: spec-matches? ( value spec -- ? )
-    #! Depends on node@
+    2dup first value-matches?
-    node@ node-input-classes +input+ get
+    >r >r operand-class 2 r> ?nth class-matches? r> and ;
-    [ 2 swap ?nth class-match? ] 2all? ;
+
+: template-specs-match? ( -- ? )
+    phantom-d get +input+ get
+    [ spec-matches? ] phantom&spec-agree? ;
 
 : template-matches? ( spec -- ? )
-    #! Depends on node@
     clone [
         template-specs-match?
-        template-classes-match? and
         [ guess-template-vregs free-vregs? ] [ f ] if
     ] bind ;
 
 : (find-template) ( templates -- pair/f )
-    #! Depends on node@
     [ second template-matches? ] find nip ;
 
+: ensure-template-vregs ( -- )
+    guess-template-vregs free-vregs? [
+        finalize-contents compute-free-vregs
+    ] unless ;
+
 PRIVATE>
 
+: set-operand-classes ( classes -- )
+    phantom-d get
+    over length over add-locs
+    [ set-operand-class ] 2reverse-each ;
+
 : end-basic-block ( -- )
     #! Commit all deferred stacking shuffling, and ensure the
     #! in-memory data and retain stacks are up to date with
@@ -547,10 +611,18 @@ PRIVATE>
     finalize-contents finalize-heights
     fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
 
-: with-template ( quot hash -- )
+: do-template ( pair -- )
+    #! Use with return value from find-template
+    first2
     clone [ template-inputs call template-outputs ] bind
-    compute-free-vregs ;
+    compute-free-vregs ; inline
-    inline
+
+: with-template ( quot hash -- )
+    clone [
+        ensure-template-vregs
+        template-inputs call template-outputs
+    ] bind
+    compute-free-vregs ; inline
 
 : fresh-object ( obj -- ) fresh-objects get push ;
 
@@ -573,17 +645,31 @@ PRIVATE>
 
 : find-template ( templates -- pair/f )
     #! Pair has shape { quot hash }
-    #! Depends on node@
     compute-free-vregs
     dup (find-template) [ ] [
         finalize-contents (find-template)
     ] ?if ;
 
-: operand-class ( operand -- class )
-    #! Depends on node@
-    +input+ get [ second = ] curry* find drop
-    node@ tuck node-in-d nth node-class ;
-
 : operand-tag ( operand -- tag/f )
-    #! Depends on node@
     operand-class class-tag ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+    operand-class immediate class< ;
+
+: phantom-push ( obj -- )
+    1 phantom-d get adjust-phantom
+    phantom-d get push ;
+
+: phantom-shuffle ( shuffle -- )
+    [ effect-in length phantom-d get phantom-input ] keep
+    shuffle* phantom-d get phantom-append ;
+
+: phantom->r ( n -- )
+    phantom-d get phantom-input
+    phantom-r get phantom-append ;
+
+: phantom-r> ( n -- )
+    phantom-r get phantom-input
+    phantom-d get phantom-append ;

core/inference/inference.factor

@@ -2,9 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference
 USING: inference.backend inference.dataflow
-inference.known-words inference.stack inference.transforms
+inference.known-words inference.transforms inference.errors
-inference.errors sequences prettyprint io effects kernel
+sequences prettyprint io effects kernel namespaces quotations ;
-namespaces quotations ;
 
 GENERIC: infer ( quot -- effect )
 

core/inference/known-words/known-words.factor

@@ -3,14 +3,58 @@
 IN: inference.known-words
 USING: alien arrays bit-arrays byte-arrays classes
 combinators.private continuations.private effects float-arrays
-generic hashtables hashtables.private
+generic hashtables hashtables.private inference.backend
-inference.backend inference.dataflow io io.backend io.files
+inference.dataflow io io.backend io.files io.files.private
-io.files.private io.streams.c kernel kernel.private math
+io.streams.c kernel kernel.private math math.private memory
-math.private memory namespaces namespaces.private parser
+namespaces namespaces.private parser prettyprint quotations
-prettyprint quotations quotations.private sbufs sbufs.private
+quotations.private sbufs sbufs.private sequences
-sequences sequences.private slots.private strings
+sequences.private slots.private strings strings.private system
-strings.private system threads.private tuples tuples.private
+threads.private tuples tuples.private vectors vectors.private
-vectors vectors.private words ;
+words assocs ;
+
+! Shuffle words
+: infer-shuffle-inputs ( shuffle node -- )
+    >r effect-in length 0 r> node-inputs ;
+
+: shuffle-stacks ( shuffle -- )
+    meta-d [ swap shuffle ] change ;
+
+: infer-shuffle-outputs ( shuffle node -- )
+    >r effect-out length 0 r> node-outputs ;
+
+: infer-shuffle ( shuffle -- )
+    dup effect-in ensure-values
+    #shuffle
+    2dup infer-shuffle-inputs
+    over shuffle-stacks
+    2dup infer-shuffle-outputs
+    node, drop ;
+
+: define-shuffle ( word shuffle -- )
+    [ infer-shuffle ] curry "infer" set-word-prop ;
+
+{
+    { drop  T{ effect f 1 {             } } }
+    { 2drop T{ effect f 2 {             } } }
+    { 3drop T{ effect f 3 {             } } }
+    { dup   T{ effect f 1 { 0 0         } } }
+    { 2dup  T{ effect f 2 { 0 1 0 1     } } }
+    { 3dup  T{ effect f 3 { 0 1 2 0 1 2 } } }
+    { rot   T{ effect f 3 { 1 2 0       } } }
+    { -rot  T{ effect f 3 { 2 0 1       } } }
+    { dupd  T{ effect f 2 { 0 0 1       } } }
+    { swapd T{ effect f 3 { 1 0 2       } } }
+    { nip   T{ effect f 2 { 1           } } }
+    { 2nip  T{ effect f 3 { 2           } } }
+    { tuck  T{ effect f 2 { 1 0 1       } } }
+    { over  T{ effect f 2 { 0 1 0       } } }
+    { pick  T{ effect f 3 { 0 1 2 0     } } }
+    { swap  T{ effect f 2 { 1 0         } } }
+} [ define-shuffle ] assoc-each
+
+\ >r [ infer->r ] "infer" set-word-prop
+
+\ r> [ infer-r> ] "infer" set-word-prop
 
 \ declare [
     1 ensure-values
@@ -22,21 +66,6 @@ vectors vectors.private words ;
     node,
 ] "infer" set-word-prop
 
-\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
-\ fixnum< make-foldable
-
-\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
-\ fixnum<= make-foldable
-
-\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
-\ fixnum> make-foldable
-
-\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
-\ fixnum>= make-foldable
-
-\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
-\ eq? make-foldable
-
 ! Primitive combinators
 GENERIC: infer-call ( value -- )
 
@@ -121,6 +150,21 @@ t over set-effect-terminated?
 "inferred-effect" set-word-prop
 
 ! Stack effects for all primitives
+\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum< make-foldable
+
+\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum<= make-foldable
+
+\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum> make-foldable
+
+\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
+\ fixnum>= make-foldable
+
+\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
+\ eq? make-foldable
+
 \ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
 
 \ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop

core/inference/stack/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

core/inference/stack/stack-docs.factor

@@ -1,11 +0,0 @@
-USING: inference.stack help.syntax help.markup ;
-
-HELP: shuffle
-{ $values { "stack" "a sequence" } { "shuffle" shuffle } { "newstack" "a new sequence" } }
-{ $description "Applies a stack shuffle pattern to a stack." }
-{ $errors "Throws an error if the input stack contains insufficient elements." } ;
-
-HELP: shuffle-stacks
-{ $values { "shuffle" "an instance of " { $link shuffle } } }
-{ $description "Applies a stack shuffle pattern to the inference stacks." }
-{ $errors "Throws an error if the stacks contain insufficient elements." } ;

core/inference/stack/stack.factor

@@ -1,64 +0,0 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: inference.stack
-USING: inference.dataflow inference.backend arrays generic
-kernel math namespaces sequences words parser words quotations
-assocs effects ;
-
-: split-shuffle ( stack shuffle -- stack1 stack2 )
-    effect-in length swap cut* ;
-
-: load-shuffle ( stack shuffle -- )
-    effect-in [ set ] 2each ;
-
-: shuffled-values ( shuffle -- values )
-    effect-out [ get ] map ;
-
-: shuffle* ( stack shuffle -- newstack )
-    [ [ load-shuffle ] keep shuffled-values ] with-scope ;
-
-: shuffle ( stack shuffle -- newstack )
-    [ split-shuffle ] keep shuffle* append ;
-
-: infer-shuffle-inputs ( shuffle node -- )
-    >r effect-in length 0 r> node-inputs ;
-
-: shuffle-stacks ( shuffle -- )
-    meta-d [ swap shuffle ] change ;
-
-: infer-shuffle-outputs ( shuffle node -- )
-    >r effect-out length 0 r> node-outputs ;
-
-: infer-shuffle ( shuffle -- )
-    dup effect-in ensure-values
-    #shuffle
-    2dup infer-shuffle-inputs
-    over shuffle-stacks
-    2dup infer-shuffle-outputs
-    node, drop ;
-
-: define-shuffle ( word shuffle -- )
-    [ infer-shuffle ] curry "infer" set-word-prop ;
-
-{
-    { drop  T{ effect f 1 {             } } }
-    { 2drop T{ effect f 2 {             } } }
-    { 3drop T{ effect f 3 {             } } }
-    { dup   T{ effect f 1 { 0 0         } } }
-    { 2dup  T{ effect f 2 { 0 1 0 1     } } }
-    { 3dup  T{ effect f 3 { 0 1 2 0 1 2 } } }
-    { rot   T{ effect f 3 { 1 2 0       } } }
-    { -rot  T{ effect f 3 { 2 0 1       } } }
-    { dupd  T{ effect f 2 { 0 0 1       } } }
-    { swapd T{ effect f 3 { 1 0 2       } } }
-    { nip   T{ effect f 2 { 1           } } }
-    { 2nip  T{ effect f 3 { 2           } } }
-    { tuck  T{ effect f 2 { 1 0 1       } } }
-    { over  T{ effect f 2 { 0 1 0       } } }
-    { pick  T{ effect f 3 { 0 1 2 0     } } }
-    { swap  T{ effect f 2 { 1 0         } } }
-} [ define-shuffle ] assoc-each
-
-\ >r [ infer->r ] "infer" set-word-prop
-
-\ r> [ infer-r> ] "infer" set-word-prop

core/inference/stack/summary.txt

@@ -1 +0,0 @@
-Stack shuffles as first-class data types