: ^^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 ;
##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
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ ds-pop ^^unbox-float @ ]
+ '[ ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
_ {
{ single-float-rep [ ^^alien-float ] }
{ double-float-rep [ ^^alien-double ] }
- } case ^^box-float
+ } case
] inline-alien-getter ;
: emit-alien-float-setter ( node rep -- )
-! 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
- ds-push ; inline
+ [ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
- [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
- ds-push ; inline
+ [ 2inputs ] dip ^^compare-float 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 ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
\ No newline at end of file
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
copy-propagation
eliminate-dead-code
eliminate-write-barriers
+ detect-loops
+ select-representations
convert-two-operand
destruct-ssa
delete-empty-blocks
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 ;
--- /dev/null
+! 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
--- /dev/null
+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
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
! 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 )
- i :> dst
- bb [ dst src int-rep ##copy ] add-instructions
+:: insert-copy ( bb src rep -- bb dst )
+ rep next-vreg :> dst
+ 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 ;
\ No newline at end of file
: 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 -- )
! 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 ]
yield-hook [ [ ] ] initialize
-: alist-max ( alist -- pair )
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+: alist-most ( alist quot -- pair )
+ [ [ ] ] 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 ;
projects / factor.git / commitdiff