tweaking stack shuffle compilation

library/bootstrap/boot-stage1.factor

@@ -124,6 +124,7 @@ sequences io vectors words ;
         "/library/inference/optimizer.factor"
         "/library/inference/inline-methods.factor"
         "/library/inference/known-words.factor"
+        "/library/inference/stack.factor"
         "/library/inference/call-optimizers.factor"
         "/library/inference/print-dataflow.factor"
         
@@ -132,6 +133,7 @@ sequences io vectors words ;
         "/library/compiler/xt.factor"
         "/library/compiler/vops.factor"
         "/library/compiler/linearizer.factor"
+        "/library/compiler/stack.factor"
         "/library/compiler/intrinsics.factor"
         "/library/compiler/simplifier.factor"
         "/library/compiler/generator.factor"

library/compiler/compiler.factor

@@ -6,21 +6,14 @@ kernel lists math namespaces prettyprint sequences words ;
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;
 
-: check-architecture ( -- )
-    supported-cpu? [
-        "Unsupported CPU; compiler disabled" throw
-    ] unless ;
-
-: compiling ( word -- word parameter )
-    check-architecture "Compiling " write dup . dup word-def ;
-
 GENERIC: (compile) ( word -- )
 
 M: word (compile) drop ;
 
 M: compound (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
-    compiling dataflow optimize linearize simplify generate ;
+    "Compiling " write dup .
+    dup word-def dataflow optimize linearize simplify generate ;
 
 : precompile ( word -- )
     #! Print linear IR of word.
@@ -40,30 +33,18 @@ M: compound (compile) ( word -- )
     #! Compile the most recently defined word.
     "compile" get [ word compile ] when ; parsing
 
-: cannot-compile ( word error -- )
-    "Cannot compile " write swap . print-error ;
-
 : try-compile ( word -- )
-    [ compile ] [ [ cannot-compile ] when* ] catch ;
+    [ compile ] [ error. ] catch ;
 
 : compile-all ( -- ) [ try-compile ] each-word ;
 
 : recompile ( word -- )
     dup update-xt compile ;
 
-: compile-1 ( quot -- word )
+: compile-1 ( quot -- )
-    #! Compute a quotation into an uninterned word, for testing
+    #! Compute and call a quotation.
-    #! purposes.
+    "compile" get [
-    gensym [ swap define-compound ] keep dup compile execute ;
+        gensym [ swap define-compound ] keep dup compile execute
-
+    ] [
-\ dataflow profile
+        call
-\ optimize profile
+    ] ifte ;
-\ linearize profile
-\ simplify profile
-\ generate profile
-\ kill-node profile
-\ partial-eval profile
-\ inline-method profile
-\ apply-identities profile
-\ subst-values profile
-\ split-branch profile

library/compiler/intrinsics.factor

@@ -10,50 +10,6 @@ sequences vectors words ;
     #! Can fixnum operations take immediate operands?
     cpu "x86" = ;
 
-\ dup [
-    drop
-    in-1
-    1 %inc-d ,
-    out-1
-] "intrinsic" set-word-prop
-
-\ swap [
-    drop
-    in-2
-    0 0 %replace-d ,
-    1 1 %replace-d ,
-] "intrinsic" set-word-prop
-
-\ over [
-    drop
-    0 1 %peek-d ,
-    1 %inc-d ,
-    out-1
-] "intrinsic" set-word-prop
-
-\ pick [
-    drop
-    0 2 %peek-d ,
-    1 %inc-d ,
-    out-1
-] "intrinsic" set-word-prop
-
-\ >r [
-    drop
-    in-1
-    1 %inc-r ,
-    1 %dec-d ,
-    0 0 %replace-r ,
-] "intrinsic" set-word-prop
-
-\ r> [
-    drop
-    0 0 %peek-r ,
-    1 %inc-d ,
-    1 %dec-r ,
-    out-1
-] "intrinsic" set-word-prop
-
 : node-peek ( node -- value ) node-in-d peek ;
 
 : type-tag ( type -- tag )
@@ -80,13 +36,13 @@ sequences vectors words ;
 
 \ slot [
     dup slot@ [
-        1 %dec-d ,
+        -1 %inc-d,
         in-1
         0 swap slot@ %fast-slot ,
     ] [
         drop
         in-2
-        1 %dec-d ,
+        -1 %inc-d,
         0 %untag ,
         1 0 %slot ,
     ] ifte  out-1
@@ -94,14 +50,14 @@ sequences vectors words ;
 
 \ set-slot [
     dup slot@ [
-        1 %dec-d ,
+        -1 %inc-d,
         in-2
-        2 %dec-d ,
+        -2 %inc-d,
         slot@ >r 0 1 r> %fast-set-slot ,
     ] [
         drop
         in-3
-        3 %dec-d ,
+        -3 %inc-d,
         1 %untag ,
         0 1 2 %set-slot ,
     ] ifte
@@ -125,17 +81,17 @@ sequences vectors words ;
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    1 %dec-d ,
+    -1 %inc-d,
     node-peek literal-value 0 <vreg> swap %getenv ,
     1 %inc-d,
     out-1
 ] "intrinsic" set-word-prop
 
 \ setenv [
-    1 %dec-d ,
+    -1 %inc-d,
     in-1
     node-peek literal-value 0 <vreg> swap %setenv ,
-    1 %dec-d ,
+    -1 %inc-d,
 ] "intrinsic" set-word-prop
 
 : value/vreg-list ( in -- list )
@@ -149,7 +105,7 @@ sequences vectors words ;
 
 : load-inputs ( node -- in )
     dup node-in-d values>vregs
-    [ length swap node-out-d length - %dec-d , ] keep ;
+    [ >r node-out-d length r> length - %inc-d, ] keep ;
 
 : binary-op-reg ( node op -- )
     >r load-inputs first2 swap dup r> execute ,
@@ -159,7 +115,7 @@ sequences vectors words ;
     dup literal? [ literal-value immediate? ] [ drop f ] ifte ;
 
 : binary-op-imm ( imm op -- )
-    1 %dec-d , in-1
+    -1 %inc-d, in-1
     >r 0 <vreg> dup r> execute ,
     0 0 %replace-d , ; inline
 
@@ -192,7 +148,7 @@ sequences vectors words ;
 ] each
 
 : fast-fixnum* ( n -- )
-    1 %dec-d ,
+    -1 %inc-d,
     in-1
     log2 0 <vreg> 0 <vreg> %fixnum<< ,
     0 0 %replace-d , ;
@@ -218,7 +174,7 @@ sequences vectors words ;
     ! be EDX there.
     drop
     in-2
-    1 %dec-d ,
+    -1 %inc-d,
     1 <vreg> 0 <vreg> 2 <vreg> %fixnum-mod ,
     2 0 %replace-d ,
 ] "intrinsic" set-word-prop
@@ -250,7 +206,7 @@ sequences vectors words ;
 : slow-shift ( -- ) \ fixnum-shift %call , ;
 
 : negative-shift ( n -- )
-    1 %dec-d ,
+    -1 %inc-d,
     in-1
     dup cell -8 * <= [
         drop 0 <vreg> 2 <vreg> %fixnum-sgn ,
@@ -262,7 +218,7 @@ sequences vectors words ;
 
 : positive-shift ( n -- )
     dup cell 8 * tag-bits - <= [
-        1 %dec-d ,
+        -1 %inc-d,
         in-1
         0 <vreg> 0 <vreg> %fixnum<< ,
         out-1
@@ -272,7 +228,7 @@ sequences vectors words ;
 
 : fast-shift ( n -- )
     dup 0 = [
-        1 %dec-d ,
+        -1 %inc-d,
         drop
     ] [
         dup 0 < [

library/compiler/linearizer.factor

@@ -59,11 +59,8 @@ M: #push linearize-node* ( node -- )
     node-out-d dup length dup %inc-d,
     1 - swap [ push-1 0 over %replace-d , ] each drop ;
 
-M: #drop linearize-node* ( node -- )
-    node-in-d length %dec-d , ;
-
 : ifte-head ( label -- )
-    in-1  1 %dec-d , 0 %jump-t , ;
+    in-1  -1 %inc-d, 0 %jump-t , ;
 
 M: #ifte linearize-node* ( node -- )
     node-children first2
@@ -76,7 +73,7 @@ M: #ifte linearize-node* ( node -- )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
     in-1
-    1 %dec-d ,
+    -1 %inc-d,
     0 %untag-fixnum ,
     0 %dispatch ,
     [ <label> dup %target-label ,  cons ] map

library/compiler/ppc/stack.factor

@@ -27,9 +27,6 @@ M: %inc-d generate-node ( vop -- )
 M: %inc-r generate-node ( vop -- )
     15 15 rot vop-in-1 cell * ADDI ;
 
-M: %dec-r generate-node ( vop -- )
-    15 15 rot vop-in-1 cell * SUBI ;
-
 M: %peek-r generate-node ( vop -- )
     dup vop-out-1 v>operand swap vop-in-1 cs-op LWZ ;
 

library/compiler/vops.factor

@@ -131,10 +131,11 @@ M: %replace-d basic-block? drop t ;
 
 TUPLE: %inc-d ;
 C: %inc-d make-vop ;
-: %inc-d ( n -- ) src-vop <%inc-d> ;
+: %inc-d ( n -- node ) src-vop <%inc-d> ;
-: %dec-d ( n -- ) neg %inc-d ;
 M: %inc-d basic-block? drop t ;
 
+: %inc-d, ( n -- ) dup 0 = [ dup %inc-d , ] unless drop ;
+
 TUPLE: %immediate ;
 C: %immediate make-vop ;
 : %immediate ( vreg obj -- )
@@ -151,12 +152,10 @@ C: %replace-r make-vop ;
 
 TUPLE: %inc-r ;
 C: %inc-r make-vop ;
+
 : %inc-r ( n -- ) src-vop <%inc-r> ;
 
-! this exists, unlike %dec-d which does not, due to x86 quirks
+: %inc-r, ( n -- ) dup 0 = [ dup %inc-r , ] unless drop ;
-TUPLE: %dec-r ;
-C: %dec-r make-vop ;
-: %dec-r ( n -- ) src-vop <%dec-r> ;
 
 : in-1 0 0 %peek-d , ;
 : in-2 0 1 %peek-d ,  1 0 %peek-d , ;

library/compiler/x86/stack.factor

@@ -4,28 +4,27 @@ IN: compiler-backend
 USING: alien assembler compiler inference kernel lists math
 memory sequences words ;
 
-: rel-cs ( -- )
-    #! Add an entry to the relocation table for the 32-bit
-    #! immediate just compiled.
-    "cs" f 0 0 rel-dlsym ;
-
-: CS ( -- [ address ] ) "cs" f dlsym unit ;
-: CS> ( register -- ) CS MOV rel-cs ;
-: >CS ( register -- ) CS swap MOV rel-cs ;
-
 : reg-stack ( reg n -- op ) cell * neg 2list ;
 : ds-op ( n -- op ) ESI swap reg-stack ;
-: cs-op ( n -- op ) ECX swap reg-stack ;
+: cs-op ( n -- op ) EBX swap reg-stack ;
 
-M: %peek-d generate-node ( vop -- )
+: (%peek) dup vop-out-1 v>operand swap vop-in-1 ;
-    dup vop-out-1 v>operand swap vop-in-1 ds-op MOV ;
 
-M: %replace-d generate-node ( vop -- )
+M: %peek-d generate-node ( vop -- ) (%peek) ds-op MOV ;
-    dup vop-in-2 v>operand swap vop-in-1 ds-op swap MOV ;
 
-M: %inc-d generate-node ( vop -- )
+M: %peek-r generate-node ( vop -- ) (%peek) cs-op MOV ;
-    ESI swap vop-in-1 cell *
+
-    dup 0 > [ ADD ] [ neg SUB ] ifte ;
+: (%replace) dup vop-in-2 v>operand swap vop-in-1 ;
+    
+M: %replace-d generate-node ( vop -- ) (%replace) ds-op swap MOV ;
+
+M: %replace-r generate-node ( vop -- ) (%replace) cs-op swap MOV ;
+
+: (%inc) swap vop-in-1 cell * dup 0 > [ ADD ] [ neg SUB ] ifte ;
+
+M: %inc-d generate-node ( vop -- ) ESI (%inc) ;
+
+M: %inc-r generate-node ( vop -- ) EBX (%inc) ;
 
 M: %immediate generate-node ( vop -- )
     dup vop-out-1 v>operand swap vop-in-1 address MOV ;
@@ -36,20 +35,3 @@ M: %immediate generate-node ( vop -- )
 M: %indirect generate-node ( vop -- )
     #! indirect load of a literal through a table
     dup vop-out-1 v>operand swap vop-in-1 load-indirect ;
-
-M: %peek-r generate-node ( vop -- )
-    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-in-1 ECX swap cell * SUB  ECX >CS ;
-
-M: %replace-r generate-node ( vop -- )
-    #! Can only follow a %inc-r
-    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-in-1 ECX swap cell * ADD ;

library/inference/dataflow.factor

@@ -57,6 +57,7 @@ M: node = eq? ;
         set-delegate
     ] keep ;
 
+: empty-node f { } { } { } { } ;
 : param-node ( label) { } { } { } { } ;
 : in-d-node ( inputs) >r f r> { } { } { } ;
 : out-d-node ( outputs) >r f { } r> { } { } ;
@@ -86,9 +87,9 @@ TUPLE: #push ;
 C: #push make-node ;
 : #push ( outputs -- node ) d-tail out-d-node <#push> ;
 
-TUPLE: #drop ;
+TUPLE: #shuffle ;
-C: #drop make-node ;
+C: #shuffle make-node ;
-: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
+: #shuffle ( -- node ) empty-node <#shuffle> ;
 
 TUPLE: #values ;
 C: #values make-node ;
@@ -163,6 +164,9 @@ SYMBOL: current-node
 : uses-value? ( value node -- ? )
     node-values [ value-refers? ] contains-with? ;
 
+: outputs-value? ( value node -- ? )
+    2dup node-out-d member? >r node-out-r member? r> or ;
+
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;
 
@@ -174,8 +178,11 @@ SYMBOL: current-node
         2drop f
     ] ifte ;
 
-: drop-inputs ( node -- #drop )
+: drop-inputs ( node -- #shuffle )
-    node-in-d clone in-d-node <#drop> ;
+    node-in-d clone in-d-node <#shuffle> ;
+
+: #drop ( n -- #shuffle )
+    d-tail in-d-node <#shuffle> ;
 
 : each-node ( node quot -- | quot: node -- )
     over [

library/inference/kill-literals.factor

@@ -44,51 +44,8 @@ M: #push can-kill? ( literal node -- ? ) 2drop t ;
 M: #push kill-node* ( literals node -- )
     [ node-out-d seq-diff ] keep set-node-out-d ;
 
-! #drop
+! #shuffle
-M: #drop can-kill? ( literal node -- ? ) 2drop t ;
+M: #shuffle can-kill? ( literal node -- ? ) 2drop t ;
-
-! #call
-: (kill-shuffle) ( word -- map )
-    {{
-        [[ dup {{ }} ]]
-        [[ drop {{ }} ]]
-        [[ swap {{ }} ]]
-        [[ over
-            {{
-                [[ { f t } dup  ]]
-            }}
-        ]]
-        [[ pick
-            {{
-                [[ { f f t } over ]]
-                [[ { f t f } over ]]
-                [[ { f t t } dup  ]]
-            }}
-        ]]
-        [[ >r {{ }} ]]
-        [[ r> {{ }} ]]
-    }} hash ;
-
-M: #call can-kill? ( literal node -- ? )
-    dup node-param (kill-shuffle) >r delegate can-kill? r> or ;
-
-: kill-mask ( killing node -- mask )
-    dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
-    [ swap memq? ] map-with ;
-
-: lookup-mask ( mask word -- word )
-    over [ ] contains? [ (kill-shuffle) hash ] [ nip ] ifte ;
-
-: kill-shuffle ( literals node -- )
-    #! If certain values passing through a stack op are being
-    #! killed, the stack op can be reduced, in extreme cases
-    #! to a no-op.
-    [ [ kill-mask ] keep node-param lookup-mask ] keep
-    set-node-param ;
-
-M: #call kill-node* ( literals node -- )
-    dup node-param (kill-shuffle)
-    [ kill-shuffle ] [ 2drop ] ifte ;
 
 ! #call-label
 M: #call-label can-kill? ( literal node -- ? ) 2drop t ;

library/inference/known-words.factor

@@ -37,42 +37,6 @@ memory parser sequences strings vectors words prettyprint ;
     #dispatch pop-d drop infer-branches
 ] "infer" set-word-prop
 
-! Stack manipulation
-\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop
-
-\ >r [
-    \ >r #call
-    1 0 pick node-inputs
-    pop-d push-r
-    0 1 pick node-outputs
-    node,
-] "infer" set-word-prop
-
-\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
-
-\ r> [
-    \ r> #call
-    0 1 pick node-inputs
-    pop-r push-d
-    1 0 pick node-outputs
-    node,
-] "infer" set-word-prop
-
-\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
-\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop
-
-\ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
-\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop
-
-\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
-\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop
-
-\ over [ \ over infer-shuffle ] "infer" set-word-prop
-\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop
-
-\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
-\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop
-
 ! Non-standard control flow
 \ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
 

library/inference/optimizer.factor

@@ -54,9 +54,9 @@ M: node optimize-node* ( node -- t )
 M: #push optimize-node* ( node -- node/t )
     [ node-out-d empty? ] prune-if ;
 
-! #drop
+! #shuffle
-M: #drop optimize-node*  ( node -- node/t )
+M: #shuffle optimize-node*  ( node -- node/t )
-    [ node-in-d empty? ] prune-if ;
+    [ dup node-in-d empty? swap node-in-r empty? and ] prune-if ;
 
 ! #ifte
 : static-branch? ( node -- lit ? )

library/inference/print-dataflow.factor

@@ -16,28 +16,24 @@ M: comment pprint* ( ann -- )
 : comment, ( ? node text -- )
     rot [ <comment> , ] [ 2drop ] ifte ;
 
-: value-str ( classes values -- str )
+: value-str ( prefix values -- str )
-    [ swap hash [ object ] unless* ] map-with
+    [ value-uid word-name append ] map-with
-    [ word-name ] map
     " " join ;
 
 : effect-str ( node -- str )
     [
-        dup node-classes swap
+        "" over node-in-d value-str %
-        2dup node-in-d value-str %
+        "r: " over node-in-r value-str %
         "--" %
-        node-out-d value-str %
+        "" over node-out-d value-str %
+        "r: " swap node-out-r value-str %
     ] "" make ;
 
 M: #push node>quot ( ? node -- )
     node-out-d [ literal-value literalize ] map % drop ;
 
-M: #drop node>quot ( ? node -- )
+M: #shuffle node>quot ( ? node -- )
-    node-in-d length dup 3 > [
+    >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
-        \ drop <repeated>
-    ] [
-        { f [ drop ] [ 2drop ] [ 3drop ] } nth
-    ] ifte % drop ;
 
 DEFER: dataflow>quot
 

library/inference/words.factor

@@ -143,9 +143,3 @@ M: compound apply-object ( word -- )
         dup "inline" word-prop
         [ inline-block block, ] [ apply-default ] ifte
     ] ifte* ;
-
-: infer-shuffle ( word -- )
-    dup #call [
-        over "infer-effect" word-prop
-        [ meta-d [ swap with-datastack ] change ] hairy-node
-    ] keep node, ;

library/test/compiler/optimizer.factor

@@ -37,11 +37,6 @@ USE: prettyprint
 
 [ { [ 1 ] [ 2 ] } ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
 
-[ [ t t f ] ] [
-    [ 1 2 3 ] [ <literal> ] map
-    [ [ literal-value 2 <= ] subset ] keep in-d-node <#drop> kill-mask
-] unit-test
-
 : literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
 
 [ 4 ] [ literal-kill-test-1 drop ] unit-test

library/test/compiler/stack.factor

@@ -6,6 +6,24 @@ USE: lists
 USE: math
 USE: kernel
 
+! Test shuffle intrinsics
+[ ] [ 1 [ drop ] compile-1 ] unit-test
+[ ] [ 1 2 [ 2drop ] compile-1 ] unit-test
+[ ] [ 1 2 3 [ 3drop ] compile-1 ] unit-test
+[ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
+[ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-1 ] unit-test
+[ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-1 ] unit-test
+[ 2 3 1 ] [ 1 2 3 [ rot ] compile-1 ] unit-test
+[ 3 1 2 ] [ 1 2 3 [ -rot ] compile-1 ] unit-test
+[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
+[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-1 ] unit-test
+[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
+[ 3 ] [ 1 2 3 [ 2nip ] compile-1 ] unit-test
+[ 2 1 2 ] [ 1 2 [ tuck ] compile-1 ] unit-test
+[ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
+[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
+[ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
+
 ! Test various kill combinations
 
 : kill-1

library/tools/debugger.factor

@@ -44,6 +44,8 @@ parser prettyprint sequences io strings vectors words ;
 PREDICATE: cons kernel-error ( obj -- ? )
     car kernel-error = ;
 
+M: f error. ( f -- ) ;
+
 M: kernel-error error. ( error -- )
     #! Kernel errors are indexed by integers.
     cdr uncons car swap {

native/factor.h

@@ -9,7 +9,6 @@
 	#define DLLEXPORT
 #endif
 
-/* CELL must be 32 bits and your system must have 32-bit pointers */
 typedef unsigned long int CELL;
 #define CELLS ((signed)sizeof(CELL))
 
@@ -29,10 +28,12 @@ CELL ds_bot;
 CELL cs_bot;
 
 /* raw pointer to callstack top */
-#if defined(FACTOR_PPC)
+#if defined(FACTOR_X86)
+	register CELL cs asm("ebx");
+#elif defined(FACTOR_PPC)
 	register CELL cs asm("r15");
 #else
-	DLLEXPORT CELL cs;
+	CELL cs;
 #endif
 
 /* TAGGED currently executing quotation */