RPO linearization

unfinished/compiler/cfg/builder/builder-tests.factor

@@ -1,12 +1,10 @@
 IN: compiler.cfg.builder.tests
-USING: compiler.cfg.builder tools.test kernel sequences
+USING: tools.test kernel sequences
+words sequences.private fry prettyprint alien
 math.private compiler.tree.builder compiler.tree.optimizer
-words sequences.private fry prettyprint alien ;
+compiler.cfg.builder compiler.cfg.debugger  ;
 
 ! Just ensure that various CFGs build correctly.
-: test-cfg ( quot -- result )
-    build-tree optimize-tree gensym gensym build-cfg ;
-
 {
     [ ]
     [ dup ]
@@ -28,10 +26,6 @@ words sequences.private fry prettyprint alien ;
     '[ _ test-cfg drop ] [ ] swap unit-test
 ] each
 
-: test-word-cfg ( word -- result )
-    [ build-tree-from-word nip optimize-tree ] keep dup
-    build-cfg ;
-
 : test-1 ( -- ) test-1 ;
 : test-2 ( -- ) 3 . test-2 ;
 : test-3 ( a -- b ) dup [ test-3 ] when ;
@@ -41,5 +35,5 @@ words sequences.private fry prettyprint alien ;
     test-2
     test-3
 } [
-    '[ _ test-word-cfg drop ] [ ] swap unit-test
+    '[ _ test-cfg drop ] [ ] swap unit-test
 ] each

unfinished/compiler/cfg/builder/builder.factor

@@ -30,6 +30,8 @@ IN: compiler.cfg.builder
     building off
     basic-block off ;
 
+: stop-iterating ( -- next ) end-basic-block f ;
+
 USE: qualified
 FROM: compiler.generator.registers => +input+   ;
 FROM: compiler.generator.registers => +output+  ;
@@ -49,7 +51,7 @@ SYMBOL: current-label-start
 
 : add-procedure ( -- )
     basic-block get current-word get current-label get
-    <procedure> procedures get push ;
+    <cfg> procedures get push ;
 
 : begin-procedure ( word label -- )
     end-basic-block
@@ -100,17 +102,17 @@ GENERIC: emit-node ( node -- next )
 : if-intrinsics ( #call -- quot )
     word>> "if-intrinsics" word-prop ;
 
-: local-recursive-call ( basic-block -- )
+: local-recursive-call ( basic-block -- next )
     %branch
     basic-block get successors>> push
-    end-basic-block ;
+    stop-iterating ;
 
 : emit-call ( word -- next )
     finalize-phantoms
     {
         { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
-        { [ dup loops get key? ] [ loops get at local-recursive-call f ] }
+        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
-        [ %epilogue %jump f ]
+        [ %epilogue %jump stop-iterating ]
     } cond ;
 
 ! #recursive
@@ -265,7 +267,7 @@ M: #return-recursive emit-node
     [ %epilogue %return ] unless f ;
 
 ! #terminate
-M: #terminate emit-node drop end-basic-block f ;
+M: #terminate emit-node drop stop-iterating ;
 
 ! FFI
 M: #alien-invoke emit-node

unfinished/compiler/cfg/cfg.factor

@@ -3,45 +3,25 @@
 USING: kernel accessors namespaces assocs sequences sets fry ;
 IN: compiler.cfg
 
-TUPLE: procedure entry word label ;
+TUPLE: cfg entry word label ;
 
-C: <procedure> procedure
+C: <cfg> cfg
 
-! - "id" is a globally unique id used for hashcode*.
+! - "number" and "visited" is used by linearization.
-! - "number" is assigned by linearization.
 TUPLE: basic-block < identity-tuple
-id
+visited
 number
 label
 instructions
 successors
 predecessors ;
 
-SYMBOL: next-block-id
-
 : <basic-block> ( -- basic-block )
     basic-block new
-        next-block-id counter >>id
         V{ } clone >>instructions
         V{ } clone >>successors
         V{ } clone >>predecessors ;
 
-M: basic-block hashcode* id>> nip ;
+TUPLE: mr instructions word label ;
 
-! Utilities
+C: <mr> mr
-SYMBOL: visited-blocks
-
-: visit-block ( basic-block quot -- )
-    over visited-blocks get 2dup key?
-    [ 2drop 2drop ] [ conjoin call ] if ; inline
-
-: (each-block) ( basic-block quot -- )
-    '[
-        _
-        [ call ]
-        [ [ successors>> ] dip '[ _ (each-block) ] each ]
-        2bi
-    ] visit-block ; inline
-
-: each-block ( basic-block quot -- )
-    H{ } clone visited-blocks [ (each-block) ] with-variable ; inline

unfinished/compiler/cfg/debugger/debugger.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences quotations namespaces io
+accessors prettyprint prettyprint.config
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.linearization ;
+IN: compiler.cfg.debugger
+
+GENERIC: test-cfg ( quot -- cfgs )
+
+M: callable test-cfg
+    build-tree optimize-tree gensym gensym build-cfg ;
+
+M: word test-cfg
+    [ build-tree-from-word nip optimize-tree ] keep dup
+    build-cfg ;
+
+: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
+
+: mr. ( mrs -- )
+    [
+        boa-tuples? on
+        "=== word: " write
+        dup word>> pprint
+        ", label: " write
+        dup label>> pprint nl nl
+        instructions>> .
+        nl
+    ] each ;

unfinished/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences math math.order kernel assocs
 accessors vectors fry
-compiler.machine.linear-scan.live-intervals
+compiler.cfg.linear-scan.live-intervals
 compiler.backend ;
-IN: compiler.machine.linear-scan.allocation
+IN: compiler.cfg.linear-scan.allocation
 
 ! Mapping from vregs to machine registers
 SYMBOL: register-allocation

unfinished/compiler/cfg/linear-scan/linear-scan.factor

@@ -1,12 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.machine.linear-scan
+IN: compiler.cfg.linear-scan
 
 ! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
 
-! ! ! Step 1: compute live intervals
-
-
-! ! ! Step 2: allocate registers
-
-

unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math
 math.order sorting compiler.instructions compiler.registers ;
-IN: compiler.machine.linear-scan.live-intervals
+IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-interval < identity-tuple vreg start end ;
 

unfinished/compiler/cfg/linearization/linearization.factor

@@ -0,0 +1,93 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces make
+combinators compiler.cfg compiler.cfg.rpo compiler.instructions
+compiler.instructions.syntax ;
+IN: compiler.cfg.linearization
+
+! Convert CFG IR to machine IR.
+SYMBOL: frame-size
+
+: compute-frame-size ( rpo -- )
+    [ instructions>> [ %frame-required? ] filter ] map concat
+    [ f ] [ [ n>> ] map supremum ] if-empty
+    frame-size set ;
+
+GENERIC: linearize-insn ( basic-block insn -- )
+
+: linearize-insns ( basic-block -- )
+    dup instructions>> [ linearize-insn ] with each ; inline
+
+M: insn linearize-insn , drop ;
+
+M: %frame-required linearize-insn 2drop ;
+
+M: %prologue linearize-insn
+    2drop frame-size get [ _prologue ] when* ;
+
+M: %epilogue linearize-insn
+    2drop frame-size get [ _epilogue ] when* ;
+
+: useless-branch? ( basic-block successor -- ? )
+    #! If our successor immediately follows us in RPO, then we
+    #! don't need to branch.
+    [ number>> 1+ ] [ number>> ] bi* = ; inline
+
+: branch-to-return? ( successor -- ? )
+    #! A branch to a block containing just a return is cloned.
+    instructions>> dup length 2 = [
+        [ first %epilogue? ] [ second %return? ] bi and
+    ] [ drop f ] if ;
+
+: emit-branch ( basic-block successor -- )
+    {
+        { [ 2dup useless-branch? ] [ 2drop ] }
+        { [ dup branch-to-return? ] [ nip linearize-insns ] }
+        [ nip label>> _branch ]
+    } cond ;
+
+M: %branch linearize-insn
+    drop dup successors>> first emit-branch ;
+
+: conditional ( basic-block -- basic-block successor1 label2 )
+    dup successors>> first2 swap label>> ; inline
+
+: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
+    [ conditional ] [ vreg>> ] bi* swap ; inline
+
+M: %branch-f linearize-insn
+    boolean-conditional _branch-f emit-branch ;
+
+M: %branch-t linearize-insn
+    boolean-conditional _branch-t emit-branch ;
+
+M: %if-intrinsic linearize-insn
+    [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
+    _if-intrinsic emit-branch ;
+
+M: %boolean-intrinsic linearize-insn
+    [
+        "false" define-label
+        "end" define-label
+        "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
+        t over out>> %load-literal
+        "end" get _branch
+        "false" resolve-label
+        f over out>> %load-literal
+        "end" resolve-label
+    ] with-scope
+    2drop ;
+
+: linearize-basic-block ( bb -- )
+    [ label>> _label ] [ linearize-insns ] bi ;
+
+: linearize-basic-blocks ( rpo -- insns )
+    [ [ linearize-basic-block ] each ] { } make ;
+
+: build-mr ( cfg -- mr )
+    [
+        entry>> reverse-post-order [
+            [ compute-frame-size ]
+            [ linearize-basic-blocks ] bi
+        ] with-scope
+    ] [ word>> ] [ label>> ] tri <mr> ;

unfinished/compiler/cfg/rpo/rpo.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces make math sequences
+compiler.instructions ;
+IN: compiler.cfg.rpo
+
+: post-order-traversal ( basic-block -- )
+    dup visited>> [ drop ] [
+        t >>visited
+        <label> >>label
+        [ successors>> [ post-order-traversal ] each ] [ , ] bi
+    ] if ;
+
+: post-order ( procedure -- blocks )
+    [ post-order-traversal ] { } make ;
+
+: number-blocks ( blocks -- )
+    [ >>number drop ] each-index ;
+
+: reverse-post-order ( procedure -- blocks )
+    post-order <reversed> dup number-blocks ; inline

unfinished/compiler/instructions/instructions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences
+USING: assocs accessors arrays kernel sequences namespaces
-compiler.instructions.syntax ;
+math compiler.instructions.syntax ;
 IN: compiler.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
@@ -17,9 +17,6 @@ INSN: %inc-r n ;
 INSN: %load-literal obj vreg ;
 
 ! Calling convention
-INSN: %prologue ;
-INSN: %epilogue ;
-INSN: %frame-required n ;
 INSN: %return ;
 
 ! Subroutine calls
@@ -31,15 +28,6 @@ INSN: %intrinsic quot vregs ;
 INSN: %dispatch-label label ;
 INSN: %dispatch ;
 
-! Unconditional branch to successor (CFG only)
-INSN: %branch ;
-
-! Conditional branches (CFG only)
-INSN: %branch-f < %cond-branch ;
-INSN: %branch-t < %cond-branch ;
-INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs out ;
-
 ! Boxing and unboxing
 INSN: %copy < %unary ;
 INSN: %copy-float < %unary ;
@@ -64,9 +52,45 @@ M: insn uses-vregs drop f ;
 M: %peek uses-vregs vreg>> 1array ;
 M: %replace uses-vregs vreg>> 1array ;
 M: %load-literal uses-vregs vreg>> 1array ;
-M: %cond-branch uses-vregs vreg>> 1array ;
 M: %unary uses-vregs [ dst>> ] [ src>> ] bi 2array ;
 M: %intrinsic uses-vregs vregs>> values ;
+
+! Instructions used by CFG IR only.
+INSN: %prologue ;
+INSN: %epilogue ;
+INSN: %frame-required n ;
+
+INSN: %branch ;
+INSN: %branch-f < %cond-branch ;
+INSN: %branch-t < %cond-branch ;
+INSN: %if-intrinsic quot vregs ;
+INSN: %boolean-intrinsic quot vregs out ;
+
+M: %cond-branch uses-vregs vreg>> 1array ;
 M: %if-intrinsic uses-vregs vregs>> values ;
 M: %boolean-intrinsic uses-vregs
     [ vregs>> values ] [ out>> ] bi suffix ;
+
+! Instructions used by machine IR only.
+INSN: _prologue n ;
+INSN: _epilogue n ;
+
+TUPLE: label id ;
+
+INSN: _label label ;
+
+: <label> ( -- label ) \ <label> counter label boa ;
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless _label ;
+
+TUPLE: _cond-branch vreg label ;
+
+INSN: _branch label ;
+INSN: _branch-f < _cond-branch ;
+INSN: _branch-t < _cond-branch ;
+INSN: _if-intrinsic label quot vregs ;
+
+M: _cond-branch uses-vregs vreg>> 1array ;
+M: _if-intrinsic uses-vregs vregs>> values ;

unfinished/compiler/machine/builder/builder.factor

@@ -1,72 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-compiler.cfg compiler.instructions compiler.machine ;
-IN: compiler.machine.builder
-
-! Convert CFG IR to machine IR.
-
-SYMBOL: block-counter
-
-: number-basic-block ( basic-block -- )
-    #! Make this fancy later.
-    dup number>> [ drop ] [
-        <label> >>label
-        block-counter [ dup 1+ ] change >>number
-        [ , ] [
-            successors>> <reversed>
-            [ number-basic-block ] each
-        ] bi
-    ] if ;
-
-: flatten-basic-blocks ( procedure -- blocks )
-    [
-        0 block-counter
-        [ number-basic-block ]
-        with-variable
-    ] { } make ;
-
-GENERIC: linearize* ( basic-block insn -- )
-
-M: object linearize* , drop ;
-
-M: %branch linearize*
-    drop successors>> first label>> _branch ;
-
-: conditional ( basic-block -- label1 label2 )
-    successors>> first2 [ label>> ] bi@ swap ; inline
-
-: boolean-conditional ( basic-block insn -- label1 vreg label2 )
-    [ conditional ] [ vreg>> ] bi* swap ; inline
-
-M: %branch-f linearize*
-    boolean-conditional _branch-f _branch ;
-
-M: %branch-t linearize*
-    boolean-conditional _branch-t _branch ;
-
-M: %if-intrinsic linearize*
-    [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
-    _if-intrinsic _branch ;
-
-M: %boolean-intrinsic linearize*
-    [
-        "false" define-label
-        "end" define-label
-        "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
-        t over out>> %load-literal
-        "end" get _branch
-        "false" resolve-label
-        f over out>> %load-literal
-        "end" resolve-label
-    ] with-scope
-    2drop ;
-
-: build-machine ( procedure -- insns )
-    [
-        entry>> flatten-basic-blocks [
-            [ label>> _label ]
-            [ dup instructions>> [ linearize* ] with each ]
-            bi
-        ] each
-    ] { } make ;

unfinished/compiler/machine/machine.factor

@@ -1,27 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays namespaces kernel math
-sequences compiler.instructions compiler.instructions.syntax ;
-IN: compiler.machine
-
-! Machine representation. Flat list of instructions, all
-! registers allocated, with labels and jumps.
-
-INSN: _prologue n ;
-INSN: _epilogue n ;
-
-INSN: _label label ;
-
-: <label> ( -- label ) \ <label> counter ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup integer? [ get ] unless _label ;
-
-TUPLE: _cond-branch vreg label ;
-
-INSN: _branch label ;
-INSN: _branch-f < _cond-branch ;
-INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot vregs ;
-
-M: _cond-branch uses-vregs vreg>> 1array ;
-M: _if-intrinsic uses-vregs vregs>> values ;

unfinished/compiler/machine/optimizer/optimizer-tests.factor

@@ -1,4 +0,0 @@
-IN: compiler.machine.optimizer.tests
-USING: compiler.machine.optimizer tools.test ;
-
-\ optimize-machine must-infer

unfinished/compiler/machine/optimizer/optimizer.factor

@@ -1,39 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math namespaces make sequences
-sequences.next
-compiler.instructions
-compiler.instructions.syntax
-compiler.machine ;
-IN: compiler.machine.optimizer
-
-: frame-required ( insns -- n/f )
-    [ %frame-required? ] filter
-    [ f ] [ [ n>> ] map supremum ] if-empty ;
-
-GENERIC: optimize* ( next insn -- )
-
-: useless-branch? ( next insn -- ? )
-    over _label? [ [ label>> ] bi@ = ] [ 2drop f ] if ;
-
-M: _branch optimize*
-    #! Remove unconditional branches to labels immediately
-    #! following.
-    tuck useless-branch? [ drop ] [ , ] if ;
-
-M: %prologue optimize*
-    2drop \ frame-required get [ _prologue ] when* ;
-
-M: %epilogue optimize*
-    2drop \ frame-required get [ _epilogue ] when* ;
-
-M: %frame-required optimize* 2drop ;
-
-M: insn optimize* nip , ;
-
-: optimize-machine ( insns -- insns )
-    [
-        [ frame-required \ frame-required set ]
-        [ [ optimize* ] each-next ]
-        bi
-    ] { } make ;