compiler work

TODO.FACTOR.txt

@@ -12,14 +12,13 @@
 - handle recursion with when, when* etc
 - optimizer rewrite stack ops
 - alien-call need special nodes
-- fix dataflow unit tests
+- mutual recursion is borked with certain branch order
+- fix inference of + = and others
 
 + linearizer/generator:
 
 - peephole optimizer
 - linearize generic, 2generic
-- generate conditionals
-- generator needs to be aware of labels
 - getenv/setenv: if literal arg, compile as a load/store
 - compiler: drop literal peephole optimization
 

library/compiler/compiler.factor

@@ -44,9 +44,15 @@ USE: unparser
 USE: vectors
 USE: words
 
+! <LittleDan> peephole?
+! <LittleDan> "whose peephole are we optimizing" "your mom's"
+
+: begin-compiling ( word -- definition )
+    cell compile-aligned dup save-xt word-parameter ;
+
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
-    dup save-xt word-parameter dataflow linearize generate ;
+    begin-compiling dataflow optimize linearize generate ;
 
 : compile-postponed ( -- )
     compile-words get [
@@ -56,7 +62,7 @@ USE: words
 : compile ( word -- )
     [ postpone-word compile-postponed ] with-compiler ;
 
-: compiled
+: compiled ( -- )
     #! Compile the most recently defined word.
     word compile ; parsing
 

library/compiler/generator-x86.factor

@@ -93,6 +93,43 @@ USE: words
     "arithmetic_type" SELF-CALL
     8 ESP R+I ;
 
-\ #push [ compile-literal ] "generator" set-word-property
-\ #call [ CALL compiled-offset defer-xt ] "generator" set-word-property
-\ #return [ drop RET ] "generator" set-word-property
+#push [ compile-literal ] "generator" set-word-property
+
+#call [
+    dup postpone-word
+    CALL compiled-offset defer-xt
+] "generator" set-word-property
+
+#call-label [
+    CALL compiled-offset defer-xt
+] "generator" set-word-property
+
+#jump-label [
+    JUMP compiled-offset defer-xt
+] "generator" set-word-property
+
+#jump-label-t [
+    POP-DS
+    ! condition is now in EAX
+    f address EAX CMP-I-R
+    ! jump w/ address added later
+    JNE compiled-offset defer-xt
+] "generator" set-word-property
+
+#return [ drop RET ] "generator" set-word-property
+
+#drop [ drop  4 ESI R-I ] "generator" set-word-property
+#dup [
+    drop
+    ESI EAX [R]>R
+    4 ESI R+I
+    EAX ESI R>[R]
+] "generator" set-word-property
+
+#swap [ drop \ swap CALL compiled-offset defer-xt ] "generator" set-word-property
+#over [ drop \ over CALL compiled-offset defer-xt ] "generator" set-word-property
+#nip [ drop \ nip CALL compiled-offset defer-xt ] "generator" set-word-property
+#tuck [ drop \ tuck CALL compiled-offset defer-xt ] "generator" set-word-property
+#rot [ drop \ rot CALL compiled-offset defer-xt ] "generator" set-word-property
+#>r [ drop \ >r CALL compiled-offset defer-xt ] "generator" set-word-property
+#r> [ drop \ r> CALL compiled-offset defer-xt ] "generator" set-word-property

library/compiler/generator.factor

@@ -47,3 +47,6 @@ USE: words
 : generate ( linear -- )
     #! Compile a word definition from linear IR.
     [ generate-node ] each ;
+
+#label [ save-xt ] "generator" set-word-property
+#values [ nop ] "generator" set-word-property

library/compiler/optimizer.factor

@@ -114,8 +114,10 @@ USE: logic
     #! is destructively modified.
     dup kill-set swap kill-nodes ;
 
-: kill-branches ( literals branchlist -- branchlist )
-    [ dupd kill-nodes ] map nip ;
+: kill-branches ( literals node -- )
+    [
+        node-param [ [ dupd kill-nodes ] map nip ] change
+    ] extend , ;
 
 #push [
     [ node-param get ] bind ,
@@ -135,24 +137,15 @@ USE: logic
 
 #ifte [ scan-branches ] "scan-literal" set-word-property
 #ifte [ can-kill-branches? ] "can-kill" set-word-property
-
-#ifte [ ( literals node -- )
-    [ node-param [ kill-branches ] change ] extend ,
-] "kill-node" set-word-property
+#ifte [ kill-branches ] "kill-node" set-word-property
 
 #generic [ scan-branches ] "scan-literal" set-word-property
 #generic [ can-kill-branches? ] "can-kill" set-word-property
-
-#generic [ ( literals node -- )
-    [ node-param [ kill-branches ] change ] extend ,
-] "kill-node" set-word-property
+#generic [ kill-branches ] "kill-node" set-word-property
 
 #2generic [ scan-branches ] "scan-literal" set-word-property
 #2generic [ can-kill-branches? ] "can-kill" set-word-property
-
-#2generic [ ( literals node -- )
-    [ node-param [ kill-branches ] change ] extend ,
-] "kill-node" set-word-property
+#2generic [ kill-branches ] "kill-node" set-word-property
 
 ! Don't care about inputs to recursive combinator calls
 #call-label [ 2drop t ] "can-kill" set-word-property

library/compiler/xt.factor

@@ -56,7 +56,6 @@ USE: words
 SYMBOL: compiled-xts
 
 : save-xt ( word -- )
-    cell compile-aligned
     compiled-offset swap compiled-xts acons@ ;
 
 : commit-xt ( xt word -- )

library/inference/branches.factor

@@ -50,6 +50,7 @@ USE: hashtables
         copy-interpreter
         dataflow-graph off
         infer-quot
+        ( #values values-node )
         branch-effect
     ] with-scope ;
 
@@ -131,7 +132,7 @@ USE: hashtables
     #! Infer effects for both branches, unify.
     3 ensure-d
     dataflow-drop, pop-d
-    dataflow-drop, pop-d 2list
+    dataflow-drop, pop-d swap 2list
     >r 1 meta-d get vector-tail* #ifte r>
     pop-d drop ( condition )
     infer-branches ;

library/inference/dataflow.factor

@@ -48,6 +48,11 @@ SYMBOL: #ifte
 SYMBOL: #generic
 SYMBOL: #2generic
 
+! This is purely a marker for values we retain after a
+! conditional. It does not generate code, but merely alerts the
+! dataflow optimizer to the fact these values must be retained.
+SYMBOL: #values
+
 SYMBOL: #return
 
 SYMBOL: #drop

library/inference/inference.factor

@@ -143,17 +143,22 @@ DEFER: apply-word
         2drop
     ] ifte ;
 
-: return-node ( -- )
-    #! Add a #return node to the dataflow graph.
-    f #return dataflow, [
-        meta-d get vector>list node-consume-d set
+: check-return ( -- )
+    #! Raise an error if word leaves values on return stack.
     meta-r get vector-length 0 = [
         "Word leaves elements on return stack" throw
-        ] unless
+    ] unless ;
+
+: values-node ( op -- )
+    #! Add a #values or #return node to the graph.
+    f swap dataflow, [
+        meta-d get vector>list node-consume-d set
     ] bind ;
 
 : (infer) ( quot -- )
-    f init-inference infer-quot return-node ;
+    f init-inference
+    infer-quot
+    #return values-node check-return ;
 
 : infer ( quot -- [ in | out ] )
     #! Stack effect of a quotation.

library/test/dataflow.factor

@@ -19,7 +19,15 @@ USE: words
 
 : dataflow-contains-param? ( object list -- ? )
     #! Check if some dataflow node contains a given operation.
-    [ dupd node-param swap hash = ] some? nip ;
+    [
+        dupd [
+            node-op get #label = [
+                node-param get dataflow-contains-param?
+            ] [
+                node-param get =
+            ] ifte
+        ] bind
+    ] some? nip ;
 
 [ t ] [
     \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean
@@ -82,3 +90,10 @@ SYMBOL: #test
         [ node-param | 5 ]
     }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
 ] unit-test
+
+! Somebody (cough) got the order of ifte nodes wrong.
+
+[ t ] [
+    #ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
+    [ node-param get ] bind car car [ node-param get ] bind 1 =
+] unit-test

library/test/optimizer.factor

@@ -11,3 +11,5 @@ USE: combinators
 [ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test
 
 [ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test
+
+[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test

library/test/x86-compiler/ifte.factor

@@ -29,7 +29,7 @@ USE: words
 [ 1 ] [ dummy-ifte-5 ] unit-test
 
 : dummy-ifte-6
-    dup 1 <= [
+    dup 1 fixnum<= [
         drop 1
     ] [
         1 fixnum- dup swap 1 fixnum- fixnum+