compiler.cfg.representations: new pass to make global unboxing decisions, relies on new compiler.cfg.loop-detection pass for loop nesting information

basis/compiler/cfg/hats/hats.factor

@@ -56,8 +56,6 @@ IN: compiler.cfg.hats
 : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
 : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
-: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
 : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
 : ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
 : ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;

basis/compiler/cfg/instructions/instructions.factor

@@ -250,6 +250,34 @@ UNION: kill-vreg-insn
     ##alien-indirect
     ##alien-callback ;
 
+! Instructions that output floats
+UNION: output-float-insn
+    ##add-float
+    ##sub-float
+    ##mul-float
+    ##div-float
+    ##integer>float
+    ##unbox-float
+    ##alien-float
+    ##alien-double ;
+
+! Instructions that take floats as inputs
+UNION: input-float-insn
+    ##add-float
+    ##sub-float
+    ##mul-float
+    ##div-float
+    ##float>integer
+    ##box-float
+    ##set-alien-float
+    ##set-alien-double
+    ##compare-float
+    ##compare-float-branch ;
+
+! Smackdown
+INTERSECTION: ##unary-float ##unary input-float-insn ;
+INTERSECTION: ##binary-float ##binary input-float-insn ;
+
 ! Instructions that have complex expansions and require that the
 ! output registers are not equal to any of the input registers
 UNION: def-is-use-insn

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -53,7 +53,7 @@ IN: compiler.cfg.intrinsics.alien
     inline-alien ; inline
 
 : inline-alien-float-setter ( node quot -- )
-    '[ ds-pop ^^unbox-float @ ]
+    '[ ds-pop @ ]
     [ float inline-alien-setter? ]
     inline-alien ; inline
 
@@ -95,7 +95,7 @@ IN: compiler.cfg.intrinsics.alien
         _ {
             { single-float-rep [ ^^alien-float ] }
             { double-float-rep [ ^^alien-double ] }
-        } case ^^box-float
+        } case
     ] inline-alien-getter ;
 
 : emit-alien-float-setter ( node rep -- )

basis/compiler/cfg/intrinsics/float/float.factor

@@ -1,19 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel compiler.cfg.stacks compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
-    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    [ 2inputs ] dip call ds-push ; inline
-    ds-push ; inline
 
 : emit-float-comparison ( cc -- )
-    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    [ 2inputs ] dip ^^compare-float ds-push ; inline
-    ds-push ; inline
 
 : emit-float>fixnum ( -- )
-    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+    ds-pop ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
+    ds-pop ^^untag-fixnum ^^integer>float ds-push ;

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -0,0 +1,20 @@
+IN: compiler.cfg.loop-detection.tests
+USING: compiler.cfg compiler.cfg.loop-detection
+compiler.cfg.predecessors
+compiler.cfg.debugger
+tools.test kernel namespaces accessors ;
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+
+0 { 1 2 } edges
+2 0 edge
+
+: test-loop-detection ( -- ) cfg new 0 get >>entry compute-predecessors detect-loops drop ;
+
+[ ] [ test-loop-detection ] unit-test
+
+[ 1 ] [ 0 get loop-nesting-at ] unit-test
+[ 0 ] [ 1 get loop-nesting-at ] unit-test
+[ 1 ] [ 2 get loop-nesting-at ] unit-test

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -0,0 +1,80 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators deques dlists fry kernel
+namespaces sequences sets compiler.cfg ;
+IN: compiler.cfg.loop-detection
+
+! Loop detection -- predecessors must be computed first
+
+TUPLE: natural-loop header index ends blocks ;
+
+<PRIVATE
+
+SYMBOL: loops
+
+: <natural-loop> ( header index -- loop )
+    H{ } clone H{ } clone natural-loop boa ;
+
+: lookup-header ( header -- loop )
+    loops get [
+        loops get assoc-size <natural-loop>
+    ] cache ;
+
+SYMBOLS: visited active ;
+
+: record-back-edge ( from to -- )
+    lookup-header ends>> conjoin ;
+
+DEFER: find-loop-headers
+
+: visit-edge ( from to -- )
+    dup active get key?
+    [ record-back-edge ]
+    [ nip find-loop-headers ]
+    if ;
+
+: find-loop-headers ( bb -- )
+    dup visited get key? [ drop ] [
+        {
+            [ visited get conjoin ]
+            [ active get conjoin ]
+            [ dup successors>> [ visit-edge ] with each ]
+            [ active get delete-at ]
+        } cleave
+    ] if ;
+
+SYMBOL: work-list
+
+: process-loop-block ( bb loop -- )
+    2dup blocks>> key? [ 2drop ] [
+        [ blocks>> conjoin ] [
+            2dup header>> eq? [ 2drop ] [
+                drop predecessors>> work-list get push-all-front
+            ] if
+        ] 2bi
+    ] if ;
+
+: process-loop-ends ( loop -- )
+    [ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
+    '[ _ process-loop-block ] slurp-deque ;
+
+: process-loop-headers ( -- )
+    loops get values [ process-loop-ends ] each ;
+
+SYMBOL: loop-nesting
+
+: compute-loop-nesting ( -- )
+    loops get H{ } clone [
+        [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
+    ] keep loop-nesting set ;
+
+PRIVATE>
+
+: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
+
+: detect-loops ( cfg -- cfg' )
+    H{ } clone loops set
+    H{ } clone visited set
+    H{ } clone active set
+    H{ } clone loop-nesting set
+    dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -12,6 +12,8 @@ compiler.cfg.value-numbering
 compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
+compiler.cfg.representations
+compiler.cfg.loop-detection
 compiler.cfg.two-operand
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
@@ -44,6 +46,8 @@ SYMBOL: check-optimizer?
         copy-propagation
         eliminate-dead-code
         eliminate-write-barriers
+        detect-loops
+        select-representations
         convert-two-operand
         destruct-ssa
         delete-empty-blocks

basis/compiler/cfg/registers/registers.factor

@@ -4,7 +4,7 @@ USING: accessors namespaces kernel arrays parser math math.order ;
 IN: compiler.cfg.registers
 
 ! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg { rep read-only } { n fixnum read-only } ;
+TUPLE: vreg rep { n fixnum read-only } ;
 
 M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
 

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -0,0 +1,82 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences arrays fry namespaces
+cpu.architecture compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.representations.preferred
+
+GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: temp-vreg-reps ( insn -- reps )
+GENERIC: uses-vreg-reps ( insn -- reps )
+
+M: ##flushable defs-vreg-rep drop int-rep ;
+M: ##copy defs-vreg-rep rep>> ;
+M: output-float-insn defs-vreg-rep drop double-float-rep ;
+M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
+M: _fixnum-overflow defs-vreg-rep drop int-rep ;
+M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
+M: insn defs-vreg-rep drop f ;
+
+M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
+M: ##unary/temp temp-vreg-reps drop { int-rep } ;
+M: ##allot temp-vreg-reps drop { int-rep } ;
+M: ##dispatch temp-vreg-reps drop { int-rep } ;
+M: ##slot temp-vreg-reps drop { int-rep } ;
+M: ##set-slot temp-vreg-reps drop { int-rep } ;
+M: ##string-nth temp-vreg-reps drop { int-rep } ;
+M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
+M: ##compare temp-vreg-reps drop { int-rep } ;
+M: ##compare-imm temp-vreg-reps drop { int-rep } ;
+M: ##compare-float temp-vreg-reps drop { int-rep } ;
+M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
+M: _dispatch temp-vreg-reps drop { int-rep } ;
+M: insn temp-vreg-reps drop f ;
+
+M: ##copy uses-vreg-reps rep>> 1array ;
+M: ##unary uses-vreg-reps drop { int-rep } ;
+M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
+M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
+M: ##binary-imm uses-vreg-reps drop { int-rep } ;
+M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##effect uses-vreg-reps drop { int-rep } ;
+M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
+M: ##slot-imm uses-vreg-reps drop { int-rep } ;
+M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
+M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
+M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: ##dispatch uses-vreg-reps drop { int-rep } ;
+M: ##alien-getter uses-vreg-reps drop { int-rep } ;
+M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
+M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
+M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
+M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
+M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
+M: _dispatch uses-vreg-reps drop { int-rep } ;
+M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
+M: insn uses-vreg-reps drop f ;
+
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
+
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
+
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+    '[
+        [ basic-block set ] [
+            instructions>> [
+                dup ##phi? [ drop ] [
+                    _ [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri
+                ] if
+            ] each
+        ] bi
+    ] each-basic-block ; inline

basis/compiler/cfg/representations/representations-tests.factor

@@ -0,0 +1,19 @@
+USING: tools.test cpu.architecture
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+[ { double-float-rep double-float-rep } ] [
+    T{ ##add-float
+       { dst V double-float-rep 5 }
+       { src1 V double-float-rep 3 }
+       { src2 V double-float-rep 4 }
+    } uses-vreg-reps
+] unit-test
+
+[ double-float-rep ] [
+    T{ ##alien-double
+       { dst V double-float-rep 5 }
+       { src V int-rep 3 }
+    } defs-vreg-rep
+] unit-test

basis/compiler/cfg/representations/representations.factor

@@ -0,0 +1,157 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry accessors sequences assocs sets namespaces
+arrays combinators make locals cpu.architecture compiler.utilities
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.def-use
+compiler.cfg.utilities
+compiler.cfg.loop-detection
+compiler.cfg.renaming.functor
+compiler.cfg.representations.preferred ;
+IN: compiler.cfg.representations
+
+! Virtual register representation selection.
+! Still needs a loop nesting heuristic
+
+! For every vreg, compute possible representations.
+SYMBOL: possibilities
+
+: possible ( vreg -- reps ) possibilities get at ;
+
+: compute-possibilities ( cfg -- )
+    H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
+    [ keys ] assoc-map possibilities set ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+
+: increase-cost ( rep vreg -- )
+    ! Increase cost of keeping vreg in rep, making a choice of rep less
+    ! likely.
+    [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+
+: maybe-increase-cost ( possible vreg preferred -- )
+    pick eq? [ 2drop ] [ increase-cost ] if ;
+
+: representation-cost ( vreg preferred -- )
+    ! 'preferred' is a representation that the instruction can accept with no cost.
+    ! So, for each representation that's not preferred, increase the cost of keeping
+    ! the vreg in that representation.
+    [ drop possible ]
+    [ '[ _ _ maybe-increase-cost ] ]
+    2bi each ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+SYMBOL: preferred
+
+: minimize-costs ( -- )
+    costs get [ >alist alist-min first ] assoc-map preferred set ;
+
+: compute-costs ( cfg -- )
+    init-costs
+    [ representation-cost ] with-vreg-reps
+    minimize-costs ;
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+    2array {
+        { { int-rep int-rep } [ int-rep ##copy ] }
+        { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
+        { { double-float-rep int-rep } [ ##unbox-float ] }
+        { { int-rep double-float-rep } [ i ##box-float ] }
+    } case ;
+
+:: emit-def-conversion ( dst preferred required -- new-dst' )
+    ! If an instruction defines a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's definition to a new register, which
+    ! becomes the input of a conversion instruction.
+    dst required next-vreg [ preferred required emit-conversion ] keep ;
+
+:: emit-use-conversion ( src preferred required -- new-src' )
+    ! If an instruction uses a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's input to a new register, which
+    ! becomes the output of a conversion instruction.
+    required next-vreg [ src required preferred emit-conversion ] keep ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+    needs-renaming? off
+    V{ } clone renaming-set set ;
+
+: no-renaming ( vreg -- )
+    dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+    2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+    vreg preferred get at :> preferred
+    preferred required eq?
+    [ vreg no-renaming ]
+    [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: compute-renaming-set ( insn -- )
+    ! temp vregs don't need conversions since they're always in their
+    ! preferred representation
+    init-renaming-set
+    [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
+    [ , ]
+    [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
+    tri ;
+
+: converted-value ( vreg -- vreg' )
+    renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+    needs-renaming? get [
+        renaming-set get reverse-here
+        [ convert-insn-uses ] [ convert-insn-defs ] bi
+        renaming-set get length 0 assert=
+    ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+! Inserting conversions for a phi is done in compiler.cfg.cssa
+M: ##phi conversions-for-insn , ;
+
+M: vreg-insn conversions-for-insn
+    [ compute-renaming-set ] [ perform-renaming ] bi ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+    dup kill-block? [ drop ] [
+        [
+            [
+                [ conversions-for-insn ] each
+            ] V{ } make
+        ] change-instructions drop
+    ] if ;
+
+: insert-conversions ( cfg -- )
+    [ conversions-for-block ] each-basic-block ;
+
+: select-representations ( cfg -- cfg' )
+    {
+        [ compute-possibilities ]
+        [ compute-costs ]
+        [ insert-conversions ]
+        [ preferred get [ >>rep drop ] assoc-each ]
+    } cleave ;

basis/compiler/cfg/ssa/cssa/cssa.factor

@@ -1,22 +1,23 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals
+USING: accessors assocs kernel locals fry
 cpu.architecture
 compiler.cfg.rpo
-compiler.cfg.hats
 compiler.cfg.utilities
-compiler.cfg.instructions ;
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations ;
 IN: compiler.cfg.ssa.cssa
 
 ! Convert SSA to conventional SSA.
 
-:: insert-copy ( bb src -- bb dst )
+:: insert-copy ( bb src rep -- bb dst )
-    i :> dst
+    rep next-vreg :> dst
-    bb [ dst src int-rep ##copy ] add-instructions
+    bb [ dst src rep src rep>> emit-conversion ] add-instructions
     bb dst ;
 
 : convert-phi ( ##phi -- )
-    [ [ insert-copy ] assoc-map ] change-inputs drop ;
+    dup dst>> rep>> '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
 
 : construct-cssa ( cfg -- )
     [ [ convert-phi ] each-phi ] each-basic-block ;

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -49,7 +49,10 @@ SYMBOL: copies
 : eliminate-copy ( vreg1 vreg2 -- )
     [ leader ] bi@
     2dup eq? [ 2drop ] [
-        [ update-leaders ] [ merge-classes ] 2bi
+        [ [ rep>> ] bi@ assert= ]
+        [ update-leaders ]
+        [ merge-classes ]
+        2tri
     ] if ;
 
 : introduce-vreg ( vreg -- )

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -9,21 +9,14 @@ IN: compiler.cfg.value-numbering.simplify
 ! Return value of f means we didn't simplify.
 GENERIC: simplify* ( expr -- vn/expr/f )
 
-: simplify-unbox ( in boxer -- vn/expr/f )
-    over op>> eq? [ in>> ] [ drop f ] if ; inline
-
-: simplify-unbox-float ( in -- vn/expr/f )
-    \ ##box-float simplify-unbox ; inline
-
 : simplify-unbox-alien ( in -- vn/expr/f )
-    \ ##box-alien simplify-unbox ; inline
+    dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
 
 M: unary-expr simplify*
     #! Note the copy propagation: a copy always simplifies to
     #! its source VN.
     [ in>> vn>expr ] [ op>> ] bi {
         { \ ##copy [ ] }
-        { \ ##unbox-float [ simplify-unbox-float ] }
         { \ ##unbox-alien [ simplify-unbox-alien ] }
         { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
         [ 2drop f ]

basis/compiler/utilities/utilities.factor

@@ -26,8 +26,12 @@ SYMBOL: yield-hook
 
 yield-hook [ [ ] ] initialize
 
-: alist-max ( alist -- pair )
+: alist-most ( alist quot -- pair )
-    [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+    [ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
+
+: alist-min ( alist -- pair ) [ before? ] alist-most ;
+
+: alist-max ( alist -- pair ) [ after? ] alist-most ;
 
 : penultimate ( seq -- elt ) [ length 2 - ] keep nth ;