refactored inlined recursive blocks

TODO.FACTOR.txt

@@ -18,7 +18,6 @@
 - on win64: to_cell will break
 - .h .b .o for ratios and floats is broken
 - amd64 to do:
-  - fixnum<< overflow check
   - alien calls
   - relocation problem
   - compiling sheet runs out of memory

library/compiler/compiler.factor

@@ -1,20 +1,23 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 IN: compiler
-USING: compiler-backend compiler-frontend errors inference io
-kernel lists math namespaces optimizer prettyprint sequences
-words ;
+USING: compiler-backend compiler-frontend errors hashtables
+inference io kernel lists math namespaces optimizer prettyprint
+sequences words ;
 
-: precompile ( quotation -- basic-blocks )
-    dataflow optimize linearize split-blocks simplify ;
-
-: (compile) ( word -- )
+: (compile) ( word -- basic-blocks )
     #! Should be called inside the with-compiler scope.
-    "Compiling " write dup . flush
-    dup word-def precompile generate ;
+    dup word-def dataflow optimize linearize
+    [ split-blocks simplify generate ] hash-each ;
+
+: inform-compile ( word -- ) "Compiling " write . flush ;
 
 : compile-postponed ( -- )
-    compile-words get dup empty?
-    [ dup pop (compile) compile-postponed ] unless drop ;
+    compile-words get dup empty? [
+        dup pop
+        dup inform-compile
+        (compile)
+        compile-postponed
+    ] unless drop ;
 
 : compile ( word -- )
     [ postpone-word compile-postponed ] with-compiler ;

library/compiler/linearizer.factor

@@ -1,21 +1,45 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-frontend
-USING: arrays compiler-backend errors generic inference kernel
-lists math namespaces prettyprint sequences strings words ;
+USING: arrays compiler-backend errors generic hashtables
+inference kernel lists math namespaces prettyprint sequences
+strings words ;
 
 : in-1 0 0 %peek-d , ;
 : in-2 0 1 %peek-d ,  1 0 %peek-d , ;
 : in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
 : out-1 T{ vreg f 0 } 0 %replace-d , ;
 
+! A map from words to linear IR.
+SYMBOL: linearized
+
+! Renamed labels. To avoid problems with labels with the same
+! name in different scopes.
+SYMBOL: renamed-labels
+
+: rename-label ( label -- label )
+    <label> dup rot renamed-labels get set-hash ;
+
+: renamed-label ( label -- label )
+    renamed-labels get hash ;
+
 GENERIC: linearize* ( node -- )
 
-: linearize ( dataflow -- linear )
+: linearize-1 ( word dataflow -- )
     #! Transform dataflow IR into linear IR. This strips out
     #! stack flow information, and flattens conditionals into
     #! jumps and labels.
-    [ %prologue , linearize* ] { } make ;
+    [ %prologue , linearize* ] { } make
+    swap linearized get set-hash ;
+
+: init-linearizer ( -- )
+    H{ } clone linearized set
+    H{ } clone renamed-labels set ;
+
+: linearize ( word dataflow -- linearized )
+    #! Outputs a hashtable mapping from labels to their
+    #! respective linear IR.
+    init-linearizer linearize-1 linearized get ;
 
 : linearize-next node-successor linearize* ;
 
@@ -23,23 +47,19 @@ M: f linearize* ( f -- ) drop ;
 
 M: node linearize* ( node -- ) linearize-next ;
 
+: linearize-call ( node label -- )
+    over node-successor #return?
+    [ %jump , drop ] [ %call , linearize-next ] if ;
+
+: linearize-call-label ( node -- )
+    dup node-param rename-label linearize-call ;
+
 M: #label linearize* ( node -- )
     #! We remap the IR node's label to a new label object here,
     #! to avoid problems with two IR #label nodes having the
     #! same label in different lexical scopes.
-    <label> [
-        %return-to ,
-        <label> dup pick node-param set %label ,
-        dup node-child linearize*
-    ] keep %label ,
-    linearize-next ;
-
-: ?tail-call ( node label caller jumper -- next )
-    >r >r over node-successor #return? [
-        r> drop r> execute , drop
-    ] [
-        r> execute , r> drop linearize-next
-    ] if ; inline
+    dup linearize-call-label dup node-param renamed-label
+    swap node-child linearize-1 ;
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -61,12 +81,12 @@ M: #call linearize* ( node -- )
         dup intrinsic [
             dupd call linearize-next
         ] [
-            dup node-param \ %call \ %jump ?tail-call
+            dup node-param linearize-call
         ] if*
     ] if* ;
 
 M: #call-label linearize* ( node -- )
-    dup node-param get \ %call-label \ %jump-label ?tail-call ;
+    dup node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- )
     <label> dup in-1  -1 %inc-d , 0 %jump-t , linearize-if ;

library/compiler/ppc/generator.factor

@@ -27,15 +27,6 @@ M: %prologue generate-node ( vop -- )
     1 1 stack-increment ADDI
     0 MTLR ;
 
-M: %call-label generate-node ( vop -- )
-    #! Near calling convention for inlined recursive combinators
-    #! Note: length of instruction sequence is hard-coded.
-    vop-label
-    compiled-offset 20 + 18 LOAD32  rel-2/2 rel-address
-    1 1 stack-increment neg STWU
-    18 1 stack-increment lr@ STW
-    B ;
-
 : word-addr ( word -- )
     #! Load a word address into r3.
     dup word-xt 3 LOAD32  rel-2/2 rel-word ;
@@ -56,18 +47,9 @@ M: %call generate-node ( vop -- )
 M: %jump generate-node ( vop -- )
     drop compile-epilogue label compile-jump ;
 
-M: %jump-label generate-node ( vop -- )
-    drop label B ;
-
 M: %jump-t generate-node ( vop -- )
     drop 0 input-operand 0 swap f address CMPI label BNE ;
 
-M: %return-to generate-node ( vop -- )
-    drop
-    label 0 3 LOAD32  absolute-2/2
-    1 1 stack-increment neg STWU
-    3 1 stack-increment lr@ STW ;
-
 M: %return generate-node ( vop -- )
     drop compile-epilogue BLR ;
 

library/compiler/vops.factor

@@ -114,26 +114,14 @@ TUPLE: %return ;
 C: %return make-vop ;
 : %return empty-vop <%return> ;
 
-TUPLE: %return-to ;
-C: %return-to make-vop ;
-: %return-to label-vop <%return-to> ;
-
 TUPLE: %jump ;
 C: %jump make-vop ;
 : %jump label-vop <%jump> ;
 
-TUPLE: %jump-label ;
-C: %jump-label make-vop ;
-: %jump-label label-vop <%jump-label> ;
-
 TUPLE: %call ;
 C: %call make-vop ;
 : %call label-vop <%call> ;
 
-TUPLE: %call-label ;
-C: %call-label make-vop ;
-: %call-label label-vop <%call-label> ;
-
 TUPLE: %jump-t ;
 C: %jump-t make-vop ;
 : %jump-t <vreg> label/src-vop <%jump-t> ;

library/compiler/x86/generator.factor

@@ -8,21 +8,15 @@ kernel-internals lists math memory namespaces sequences words ;
 M: %prologue generate-node ( vop -- ) 
     drop compile-prologue ;
 
-: (call-label)
+: (%call)
     label dup postpone-word
     dup primitive? [ address-operand ] when ;
 
 M: %call generate-node ( vop -- )
-    drop (call-label) CALL ;
-
-M: %call-label generate-node ( vop -- )
-    drop label CALL ;
+    drop (%call) CALL ;
 
 M: %jump generate-node ( vop -- )
-    drop compile-epilogue (call-label) JMP ;
-
-M: %jump-label generate-node ( vop -- )
-    drop label JMP ;
+    drop compile-epilogue (%call) JMP ;
 
 M: %jump-t generate-node ( vop -- )
     drop
@@ -31,9 +25,6 @@ M: %jump-t generate-node ( vop -- )
     ! If not equal, jump
     label JNE ;
 
-M: %return-to generate-node ( vop -- )
-    drop label address-operand PUSH compile-prologue ;
-
 M: %return generate-node ( vop -- )
     drop compile-epilogue RET ;
 

library/compiler/xt.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler
-USING: assembler errors generic hashtables kernel
-kernel-internals lists math namespaces prettyprint sequences
-strings vectors words ;
+USING: assembler compiler-backend compiler-frontend errors
+generic hashtables kernel kernel-internals lists math namespaces
+prettyprint sequences strings vectors words ;
 
 ! We use a hashtable "compiled-xts" that maps words to
 ! xt's that are currently being compiled. The commit-xt's word
@@ -168,8 +168,11 @@ SYMBOL: compile-words
 : compiling? ( word -- ? )
     #! A word that is compiling or already compiled will not be
     #! added to the list of words to be compiled.
-    dup compiled? over compile-words get member? or
-    [ drop t ] [ compiled-xts get hash ] if ;
+    dup compiled?
+    over label? or
+    over linearized get hash or
+    over compile-words get member? or
+    swap compiled-xts get hash or ;
 
 : fixup-xts ( -- )
     deferred-xts get [ dup resolve swap fixup ] each ;

library/test/compiler/linearizer.factor

@@ -8,8 +8,8 @@ USE: words
 
 : fie [ ] [ ] if ;
 
-[ ] [ \ fie word-def dataflow linearize drop ] unit-test
+[ ] [ \ fie dup word-def dataflow linearize drop ] unit-test
 
 : foo [ drop ] each-word ;
 
-[ ] [ \ foo word-def dataflow linearize drop ] unit-test
+[ ] [ \ foo dup word-def dataflow linearize drop ] unit-test