More progress

unfinished/compiler/backend/x86/32/32.factor

@@ -7,5 +7,5 @@ IN: compiler.backend.x86.32
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
-        { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+        { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
     } ;

unfinished/compiler/backend/x86/64/64.factor

@@ -7,7 +7,7 @@ IN: compiler.backend.x86.64
 M: x86.64 machine-registers
     {
         { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
-        { float-regs {
+        { double-float-regs {
             XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
         } }

unfinished/compiler/cfg/instructions/instructions.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces
-math compiler.cfg.instructions.syntax ;
+math compiler.cfg.registers compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-INSN: %cond-branch src ;
-INSN: %unary dst src ;
-INSN: %nullary dst ;
+TUPLE: %cond-branch < insn src ;
+TUPLE: %unary < insn dst src ;
+TUPLE: %nullary < insn dst ;
 
 ! Stack operations
 INSN: %load-literal < %nullary obj ;
@@ -50,12 +50,12 @@ INSN: %alien-callback params ;
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: %nullary defs-vregs dst>> 1array ;
-M: %unary defs-vregs dst>> 1array ;
+M: %nullary defs-vregs dst>> >vreg 1array ;
+M: %unary defs-vregs dst>> >vreg 1array ;
 M: insn defs-vregs drop f ;
 
-M: %replace uses-vregs src>> 1array ;
-M: %unary uses-vregs src>> 1array ;
+M: %replace uses-vregs src>> >vreg 1array ;
+M: %unary uses-vregs src>> >vreg 1array ;
 M: insn uses-vregs drop f ;
 
 ! M: %intrinsic uses-vregs vregs>> values ;
@@ -75,7 +75,7 @@ M: %cond-branch uses-vregs src>> 1array ;
 
 ! M: %if-intrinsic uses-vregs vregs>> values ;
 
-M: %boolean-intrinsic defs-vregs out>> 1array ;
+M: %boolean-intrinsic defs-vregs dst>> 1array ;
 
 ! M: %boolean-intrinsic uses-vregs
 !     [ vregs>> values ] [ out>> ] bi suffix ;
@@ -94,14 +94,14 @@ INSN: _label label ;
 : resolve-label ( label/name -- )
     dup label? [ get ] unless _label ;
 
-TUPLE: _cond-branch src label ;
+TUPLE: _cond-branch < insn src 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 src>> 1array ;
+M: _cond-branch uses-vregs src>> >vreg 1array ;
 ! M: _if-intrinsic uses-vregs vregs>> values ;
 
 INSN: _spill src n ;

unfinished/compiler/cfg/instructions/syntax/syntax.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
-make parser ;
+make fry sequences parser ;
 IN: compiler.cfg.instructions.syntax
 
 TUPLE: insn ;
 
 : INSN:
-    parse-tuple-definition
+    parse-tuple-definition "regs" suffix
     [ dup tuple eq? [ drop insn ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop dup [ boa , ] curry define-inline ]
+    [ 2drop dup '[ f _ boa , ] define-inline ]
     3tri ; parsing

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

@@ -140,7 +140,7 @@ SYMBOL: spill-counter
 : init-allocator ( registers -- )
     V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
-    [ >vector ] assoc-map free-registers set
+    [ reverse >vector ] assoc-map free-registers set
     0 spill-counter set
     -1 progress set ;
 
@@ -150,10 +150,10 @@ SYMBOL: spill-counter
 : (allocate-registers) ( -- )
     unhandled-intervals get [ handle-interval ] slurp-heap ;
 
-: allocate-registers ( live-intervals machine-registers -- )
+: allocate-registers ( live-intervals machine-registers -- live-intervals )
     #! This modifies the input live-intervals.
     [
         init-allocator
-        init-unhandled
+        dup init-unhandled
         (allocate-registers)
     ] with-scope ;

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

@@ -0,0 +1,4 @@
+USING: compiler.cfg.linear-scan.assignment tools.test ;
+IN: compiler.cfg.linear-scan.assignment.tests
+
+\ assign-registers must-infer

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

@@ -5,7 +5,7 @@ fry make
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals ;
-IN: compiler.cfg.linear-scan.rewriting
+IN: compiler.cfg.linear-scan.assignment
 
 ! A vector of live intervals. There is linear searching involved
 ! but since we never have too many machine registers (around 30
@@ -55,45 +55,24 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-GENERIC: rewrite-instruction ( insn -- )
+: (assign-registers) ( insn -- )
+    dup
+    [ defs-vregs ] [ uses-vregs ] bi append
+    active-intervals get swap '[ vreg>> _ member? ] filter
+    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+    >>regs drop ;
 
-M: %cond-branch rewrite-instruction
-    [ lookup-register ] change-vreg
-    drop ;
+: init-assignment ( live-intervals -- )
+    V{ } clone active-intervals set
+    <min-heap> unhandled-intervals set
+    init-unhandled ;
 
-M: %unary rewrite-instruction
-    [ lookup-register ] change-dst
-    [ lookup-register ] change-src
-    drop ;
-
-M: %peek rewrite-instruction
-    [ lookup-register ] change-vreg
-    drop ;
-
-M: %replace rewrite-instruction
-    [ lookup-register ] change-vreg
-    drop ;
-
-M: %load-literal rewrite-instruction
-    [ lookup-register ] change-vreg
-    drop ;
-
-: lookup-registers ( assoc -- assoc' )
-    [ dup vreg? [ lookup-register ] when ] assoc-map ;
-
-M: %intrinsic rewrite-instruction
-    [ lookup-registers ] change-vregs
-    drop ;
-
-M: _if-intrinsic rewrite-instruction
-    [ lookup-registers ] change-vregs
-    drop ;
-
-: rewrite-instructions ( insns -- insns' )
+: assign-registers ( insns live-intervals -- insns' )
     [
+        init-assignment
         [
             [ activate-new-intervals ]
-            [ drop [ rewrite-instruction ] [ , ] bi ]
+            [ drop [ (assign-registers) ] [ , ] bi ]
             [ expire-old-intervals ]
             tri
         ] each-index

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

@@ -19,5 +19,5 @@ IN: compiler.cfg.linear-scan.debugger
     ] [ 1array ] if ;
 
 : check-linear-scan ( live-intervals machine-registers -- )
-    [ [ clone ] map dup ] dip allocate-registers
+    [ [ clone ] map ] dip allocate-registers
     [ split-children ] map concat check-assigned ;

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

@@ -1,6 +1,19 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors
+compiler.backend
+compiler.cfg
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.assignment ;
 IN: compiler.cfg.linear-scan
 
 ! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
 
+: linear-scan ( mr -- mr' )
+    [
+        dup compute-live-intervals
+        machine-registers allocate-registers
+        assign-registers
+    ] change-instructions ;

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

@@ -33,15 +33,17 @@ SYMBOL: live-intervals
 
 : compute-live-intervals* ( insn n -- )
     live-intervals get
-    [ [ uses-vregs ] 2dip '[ _ swap >vreg _ add-use ] each ]
-    [ [ defs-vregs ] 2dip '[ _ swap >vreg _ new-live-interval ] each ]
+    [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
+    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
     3bi ;
 
-: finalize-live-intervals ( -- )
+: finalize-live-intervals ( assoc -- seq' )
     #! Reverse uses lists so that we can pop values off.
-    live-intervals get [ nip uses>> reverse-here ] assoc-each ;
+    values dup [ uses>> reverse-here ] each ;
 
-: compute-live-intervals ( instructions -- )
-    H{ } clone live-intervals set
-    [ compute-live-intervals* ] each-index
-    finalize-live-intervals ;
+: compute-live-intervals ( instructions -- live-intervals )
+    H{ } clone [
+        live-intervals [
+            [ compute-live-intervals* ] each-index
+        ] with-variable
+    ] keep finalize-live-intervals ;

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

@@ -1,4 +0,0 @@
-USING: compiler.cfg.linear-scan.rewriting tools.test ;
-IN: compiler.cfg.linear-scan.rewriting.tests
-
-\ rewrite-instructions must-infer

unfinished/compiler/cfg/linearization/linearization.factor

@@ -56,7 +56,7 @@ M: %branch linearize-insn
     dup successors>> first2 swap label>> ; inline
 
 : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
-    [ conditional ] [ dst>> ] bi* swap ; inline
+    [ conditional ] [ src>> ] bi* swap ; inline
 
 M: %branch-f linearize-insn
     boolean-conditional _branch-f emit-branch ;
@@ -73,10 +73,10 @@ M: %boolean-intrinsic linearize-insn
         "false" define-label
         "end" define-label
         "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
-        dup out>> t %load-literal
+        dup dst>> t %load-literal
         "end" get _branch
         "false" resolve-label
-        dup out>> f %load-literal
+        dup dst>> f %load-literal
         "end" resolve-label
     ] with-scope
     2drop ;