From e21ca289c364e6d2510fb093bd35e65f6fe43db0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Aug 2009 00:24:46 -0500 Subject: [PATCH] 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 | 2 - .../cfg/instructions/instructions.factor | 28 ++++ .../cfg/intrinsics/alien/alien.factor | 4 +- .../cfg/intrinsics/float/float.factor | 12 +- .../loop-detection-tests.factor | 20 +++ .../cfg/loop-detection/loop-detection.factor | 80 +++++++++ basis/compiler/cfg/optimizer/optimizer.factor | 4 + basis/compiler/cfg/registers/registers.factor | 2 +- .../preferred/preferred.factor | 82 +++++++++ .../representations-tests.factor | 19 +++ .../representations/representations.factor | 157 ++++++++++++++++++ basis/compiler/cfg/ssa/cssa/cssa.factor | 15 +- .../cfg/ssa/destruction/destruction.factor | 5 +- .../value-numbering/simplify/simplify.factor | 9 +- basis/compiler/utilities/utilities.factor | 8 +- 15 files changed, 417 insertions(+), 30 deletions(-) create mode 100644 basis/compiler/cfg/loop-detection/loop-detection-tests.factor create mode 100644 basis/compiler/cfg/loop-detection/loop-detection.factor create mode 100644 basis/compiler/cfg/representations/preferred/preferred.factor create mode 100644 basis/compiler/cfg/representations/representations-tests.factor create mode 100644 basis/compiler/cfg/representations/representations.factor diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 735b01578f..c53709024c 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b9b0c0d599..c223db29ee 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/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 diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 0a879a67a6..246a2cb924 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/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 -- ) diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 84a0bc9ca0..152be80286 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/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 - 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 ; diff --git a/basis/compiler/cfg/loop-detection/loop-detection-tests.factor b/basis/compiler/cfg/loop-detection/loop-detection-tests.factor new file mode 100644 index 0000000000..fbb5b2340c --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor new file mode 100644 index 0000000000..9f71aba14a --- /dev/null +++ b/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 ; + + ( header index -- loop ) + H{ } clone H{ } clone natural-loop boa ; + +: lookup-header ( header -- loop ) + loops get [ + loops get assoc-size + ] 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 [ 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 diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index bae305e69e..f7a6c81d30 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/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 diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 1f786d16be..94ae2117eb 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/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 ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor new file mode 100644 index 0000000000..23be9df8c4 --- /dev/null +++ b/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 diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor new file mode 100644 index 0000000000..4345a4abef --- /dev/null +++ b/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 \ No newline at end of file diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor new file mode 100644 index 0000000000..ee72feef23 --- /dev/null +++ b/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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index faf40b57d2..e05d54b6b9 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/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 ) - 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 diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 767c71bac6..d69af0547e 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/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 -- ) diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 3a7fbf37a8..b805d7834c 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/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 ] diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index c6b7b2adc5..a17d099be4 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -26,8 +26,12 @@ SYMBOL: yield-hook 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 ;