From e27adb2830c7596390548726fabe7b37c5130862 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 Jul 2010 07:40:14 -0400 Subject: [PATCH] compiler: re-architect low-level optimizer to allow more than one output value per instruction --- .../alias-analysis-tests.factor | 16 +- .../cfg/alias-analysis/alias-analysis.factor | 8 +- .../build-stack-frame.factor | 8 +- basis/compiler/cfg/builder/alien/alien.factor | 147 +++---- .../cfg/builder/alien/boxing/boxing.factor | 84 ++-- .../cfg/builder/alien/params/params.factor | 9 +- basis/compiler/cfg/copy-prop/copy-prop.factor | 2 +- basis/compiler/cfg/dce/dce.factor | 27 +- basis/compiler/cfg/debugger/debugger.factor | 4 +- .../compiler/cfg/def-use/def-use-tests.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 77 ++-- .../compiler/cfg/dependence/dependence.factor | 2 +- .../cfg/finalization/finalization.factor | 2 +- basis/compiler/cfg/gc-checks/gc-checks.factor | 2 - basis/compiler/cfg/hats/hats.factor | 2 +- .../cfg/instructions/instructions.factor | 375 +++++++++--------- .../cfg/instructions/syntax/syntax.factor | 34 +- .../linear-scan/allocation/allocation.factor | 72 ++-- .../linear-scan/allocation/state/state.factor | 1 + .../live-intervals/live-intervals.factor | 7 +- basis/compiler/cfg/liveness/liveness.factor | 2 +- .../cfg/renaming/functor/functor.factor | 29 +- .../coalescing/coalescing.factor | 2 +- .../preferred/preferred.factor | 69 ++-- .../representations-tests.factor | 4 +- .../save-contexts/save-contexts-tests.factor | 8 - .../cfg/save-contexts/save-contexts.factor | 2 +- .../cfg/ssa/construction/construction.factor | 10 +- basis/compiler/cfg/ssa/cssa/cssa.factor | 4 +- .../cfg/ssa/destruction/destruction.factor | 8 +- .../live-ranges/live-ranges.factor | 12 +- .../expressions/expressions.factor | 5 +- .../value-numbering/value-numbering.factor | 5 +- basis/compiler/codegen/codegen.factor | 16 +- basis/cpu/architecture/architecture.factor | 26 +- basis/cpu/ppc/ppc.factor | 24 +- basis/cpu/x86/32/32.factor | 28 +- basis/cpu/x86/64/64.factor | 28 +- basis/cpu/x86/x86.factor | 126 ++++-- 39 files changed, 689 insertions(+), 600 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index 9b6fce9379..dc6ba4ad39 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -294,14 +294,14 @@ IN: compiler.cfg.alias-analysis.tests V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } ] [ V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -311,7 +311,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } ] [ @@ -319,7 +319,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -330,7 +330,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 1 D 1 } T{ ##peek f 2 D 2 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##set-slot-imm f 2 0 1 0 } } ] [ @@ -339,7 +339,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 1 D 1 } T{ ##peek f 2 D 2 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##set-slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -348,14 +348,14 @@ IN: compiler.cfg.alias-analysis.tests V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##set-slot-imm f 1 0 1 0 } } ] [ V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f "free" } + T{ ##alien-invoke f { } { } { } 0 0 "free" } T{ ##set-slot-imm f 1 0 1 0 } } test-alias-analysis ] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index aeac122832..dbceb24968 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -224,13 +224,13 @@ M: vreg-insn analyze-aliases ! anywhere its used as a tagged pointer. Boxing allocates ! a new value, except boxing instructions haven't been ! inserted yet. - dup defs-vreg [ - over defs-vreg-rep { int-rep tagged-rep } member? + dup [ + { int-rep tagged-rep } member? [ set-heap-ac ] [ set-new-ac ] if - ] when* ; + ] each-def-rep ; M: ##phi analyze-aliases - dup defs-vreg set-heap-ac ; + dup dst>> set-heap-ac ; M: ##allocation analyze-aliases #! A freshly allocated object is distinct from any other diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index a973a3721c..41882bc78f 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -21,9 +21,9 @@ M:: ##local-allot compute-stack-frame* ( insn -- ) allot-area-align [ a max ] change allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ; -M: ##stack-frame compute-stack-frame* +M: alien-call-insn compute-stack-frame* frame-required - stack-frame>> param-area-size [ max ] change ; + stack-size>> param-area-size [ max ] change ; : vm-frame-required ( -- ) frame-required @@ -33,8 +33,8 @@ M: ##call-gc compute-stack-frame* drop vm-frame-required ; M: ##box compute-stack-frame* drop vm-frame-required ; M: ##unbox compute-stack-frame* drop vm-frame-required ; M: ##box-long-long compute-stack-frame* drop vm-frame-required ; -M: ##begin-callback compute-stack-frame* drop vm-frame-required ; -M: ##end-callback compute-stack-frame* drop vm-frame-required ; +M: ##callback-inputs compute-stack-frame* drop vm-frame-required ; +M: ##callback-outputs compute-stack-frame* drop vm-frame-required ; M: ##unary-float-function compute-stack-frame* drop vm-frame-required ; M: ##binary-float-function compute-stack-frame* drop vm-frame-required ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 7e3db2cba8..c191628774 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -14,6 +14,19 @@ compiler.cfg.registers compiler.cfg.hats ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien +: with-param-regs* ( quot -- reg-values stack-values ) + '[ + V{ } clone reg-values set + V{ } clone stack-values set + @ + reg-values get + stack-values get + stack-params get + struct-return-area get + ] with-param-regs + struct-return-area set + stack-params set ; inline + : unbox-parameters ( parameters -- vregs reps ) [ [ length iota ] keep @@ -30,32 +43,23 @@ IN: compiler.cfg.builder.alien ] keep ] [ drop f ] if ; -: caller-parameter ( vreg rep on-stack? -- insn ) - [ dup reg-class-of reg-class-full? ] dip or - [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] - [ [ next-reg-param ] keep \ ##store-reg-param new-insn ] - if ; - : (caller-parameters) ( vregs reps -- ) - ! Place ##store-stack-param instructions first. This ensures - ! that no registers are used after the ##store-reg-param - ! instructions. - [ first2 caller-parameter ] 2map - [ ##store-stack-param? ] partition [ % ] bi@ ; + [ first2 next-parameter ] 2each ; -: caller-parameters ( params -- stack-size ) +: caller-parameters ( params -- reg-inputs stack-inputs ) [ abi>> ] [ parameters>> ] [ return>> ] tri '[ _ unbox-parameters _ prepare-struct-caller struct-return-area set (caller-parameters) - stack-params get - struct-return-area get - ] with-param-regs - struct-return-area set ; + ] with-param-regs* ; -: box-return* ( node -- ) - return>> [ ] [ base-type box-return ds-push ] if-void ; +: prepare-caller-return ( params -- reg-outputs ) + return>> [ { } ] [ base-type load-return ] if-void ; + +: caller-stack-frame ( params -- cleanup stack-size ) + [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup + stack-params get ; GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) @@ -79,79 +83,91 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; } 2cleave 4array ; -: alien-invoke-dlsym ( params -- symbols dll ) +: caller-linkage ( params -- symbols dll ) [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] [ library>> load-library ] bi 2dup check-dlsym ; -: emit-stack-frame ( stack-size params -- ) - [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ] - [ drop ##stack-frame ] - 2bi ; +: caller-return ( params -- ) + return>> [ ] [ + [ + building get last reg-outputs>> + flip [ { } { } ] [ first2 ] if-empty + ] dip + base-type box-return ds-push + ] if-void ; M: #alien-invoke emit-node params>> - { - [ caller-parameters ] - [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ] - [ emit-stack-frame ] - [ box-return* ] - } cleave ; + [ + { + [ caller-parameters ] + [ prepare-caller-return ] + [ caller-stack-frame ] + [ caller-linkage ] + } cleave + ##alien-invoke + ] + [ caller-return ] + bi ; M: #alien-indirect emit-node ( node -- ) params>> [ - ds-pop ^^unbox-any-c-ptr - [ caller-parameters ] dip + [ ds-pop ^^unbox-any-c-ptr ] dip + [ caller-parameters ] + [ prepare-caller-return ] + [ caller-stack-frame ] tri ##alien-indirect ] - [ emit-stack-frame ] - [ box-return* ] - tri ; + [ caller-return ] + bi ; M: #alien-assembly emit-node - params>> { - [ caller-parameters ] - [ quot>> ##alien-assembly ] - [ emit-stack-frame ] - [ box-return* ] - } cleave ; + params>> + [ + { + [ caller-parameters ] + [ prepare-caller-return ] + [ caller-stack-frame ] + [ quot>> ] + } cleave ##alien-assembly + ] + [ caller-return ] + bi ; -: callee-parameter ( rep on-stack? -- dst insn ) - [ next-vreg dup ] 2dip - [ dup reg-class-of reg-class-full? ] dip or - [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ] - [ [ next-reg-param ] keep \ ##load-reg-param new-insn ] - if ; +: callee-parameter ( rep on-stack? -- dst ) + [ next-vreg dup ] 2dip next-parameter ; : prepare-struct-callee ( c-type -- vreg ) large-struct? - [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ; + [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ; : (callee-parameters) ( params -- vregs reps ) [ flatten-parameter-type ] map - [ - [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap - concat [ ##load-reg-param? ] partition [ % ] bi@ - ] + [ [ [ first2 callee-parameter ] map ] map ] [ [ keys ] map ] bi ; : box-parameters ( vregs reps params -- ) - ##begin-callback [ box-parameter ds-push ] 3each ; + parameters>> [ base-type box-parameter ds-push ] 3each ; -: callee-parameters ( params -- stack-size ) +: callee-parameters ( params -- vregs reps reg-outputs stack-outputs ) [ abi>> ] [ return>> ] [ parameters>> ] tri '[ _ prepare-struct-callee struct-return-area set - _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi - stack-params get - struct-return-area get - ] with-param-regs - struct-return-area set ; + _ [ base-type ] map (callee-parameters) + ] with-param-regs* ; -: callback-stack-cleanup ( stack-size params -- ) - [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi +: callee-return ( params -- reg-inputs ) + return>> [ { } ] [ + [ ds-pop ] dip + base-type unbox-return store-return + ] if-void ; + +: callback-stack-cleanup ( params -- ) + [ xt>> ] + [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi "stack-cleanup" set-word-prop ; : needs-frame-pointer ( -- ) @@ -165,20 +181,15 @@ M: #alien-callback emit-node begin-word { - [ callee-parameters ] + [ callee-parameters ##callback-inputs ] + [ box-parameters ] [ [ make-kill-block quot>> ##alien-callback ] emit-trivial-block ] - [ - return>> [ ##end-callback ] [ - [ ds-pop ] dip - ##end-callback - base-type unbox-return - ] if-void - ] + [ callee-return ##callback-outputs ] [ callback-stack-cleanup ] } cleave diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 1992d7539a..48652737be 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types arrays assocs classes.struct fry -kernel layouts locals math namespaces sequences -sequences.generalizations system +USING: accessors alien.c-types arrays assocs combinators +classes.struct fry kernel layouts locals math namespaces +sequences sequences.generalizations system compiler.cfg.builder.alien.params compiler.cfg.hats -compiler.cfg.instructions cpu.architecture ; +compiler.cfg.registers compiler.cfg.instructions cpu.architecture ; IN: compiler.cfg.builder.alien.boxing SYMBOL: struct-return-area @@ -45,15 +45,23 @@ M: struct-c-type flatten-c-type GENERIC: unbox ( src c-type -- vregs reps ) M: c-type unbox - [ unboxer>> ] [ rep>> ] bi - [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ; + [ rep>> ] [ unboxer>> ] bi + [ + { + ! { "to_float" [ drop ] } + ! { "to_double" [ drop ] } + ! { "alien_offset" [ drop ^^unbox-any-c-ptr ] } + [ swap ^^unbox ] + } case 1array + ] + [ drop f 2array 1array ] 2bi ; M: long-long-type unbox [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep 0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array int-rep long-long-on-stack? 2array dup 2array ; -M: struct-c-type unbox ( src c-type -- vregs ) +M: struct-c-type unbox ( src c-type -- vregs reps ) [ ^^unbox-any-c-ptr ] dip explode-struct ; : frob-struct ( c-type -- c-type ) @@ -73,42 +81,41 @@ M: struct-c-type unbox-parameter 1array { { int-rep f } } ] if ; -GENERIC: unbox-return ( src c-type -- ) +: store-return ( vregs reps -- triples ) + [ [ dup next-return-reg 3array ] 2map ] with-return-regs ; -: store-return ( vregs reps -- ) - [ - [ [ next-return-reg ] keep ##store-reg-param ] 2each - ] with-return-regs ; +GENERIC: unbox-return ( src c-type -- vregs reps ) -: (unbox-return) ( src c-type -- vregs reps ) +M: abstract-c-type unbox-return ! Don't care about on-stack? flag when looking at return ! values. unbox keys ; -M: c-type unbox-return (unbox-return) store-return ; - -M: long-long-type unbox-return (unbox-return) store-return ; - M: struct-c-type unbox-return dup return-struct-in-registers? - [ (unbox-return) store-return ] - [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ; + [ call-next-method ] + [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ; GENERIC: flatten-parameter-type ( c-type -- reps ) -M: c-type flatten-parameter-type flatten-c-type ; - -M: long-long-type flatten-parameter-type flatten-c-type ; +M: abstract-c-type flatten-parameter-type flatten-c-type ; M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ; GENERIC: box ( vregs reps c-type -- dst ) M: c-type box - [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ; + [ [ first ] bi@ ] [ boxer>> ] bi* + { + ! { "from_float" [ drop ] } + ! { "from_double" [ drop ] } + ! { "allot_alien" [ drop ^^box-alien ] } + [ swap ^^box ] + } case ; M: long-long-type box - [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ; + [ first2 ] [ drop ] [ boxer>> ] tri* + ^^box-long-long ; M: struct-c-type box '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip @@ -116,30 +123,35 @@ M: struct-c-type box GENERIC: box-parameter ( vregs reps c-type -- dst ) -M: c-type box-parameter box ; - -M: long-long-type box-parameter box ; +M: abstract-c-type box-parameter box ; M: struct-c-type box-parameter dup value-struct? [ [ [ drop first ] dip explode-struct keys ] keep ] unless box ; -GENERIC: box-return ( c-type -- dst ) +GENERIC: load-return ( c-type -- triples ) -: load-return ( c-type -- vregs reps ) +M: abstract-c-type load-return [ flatten-c-type keys - [ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep + [ [ next-vreg ] dip dup next-return-reg 3array ] map ] with-return-regs ; -M: c-type box-return [ load-return ] keep box ; +M: struct-c-type load-return + dup return-struct-in-registers? + [ call-next-method ] [ drop { } ] if ; -M: long-long-type box-return [ load-return ] keep box ; +GENERIC: box-return ( vregs reps c-type -- dst ) + +M: abstract-c-type box-return box ; M: struct-c-type box-return + dup return-struct-in-registers? + [ call-next-method ] [ - dup return-struct-in-registers? - [ load-return ] - [ [ struct-return-area get ] dip explode-struct keys ] if - ] keep box ; + [ + [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip + explode-struct keys + ] keep box + ] if ; diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor index 4509401af0..651e5890a4 100644 --- a/basis/compiler/cfg/builder/alien/params/params.factor +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: cpu.architecture fry kernel layouts math math.order -namespaces sequences vectors assocs ; +namespaces sequences vectors assocs arrays ; IN: compiler.cfg.builder.alien.params SYMBOL: stack-params @@ -47,6 +47,13 @@ M: double-rep next-reg-param : with-param-regs ( abi quot -- ) '[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline +SYMBOLS: stack-values reg-values ; + +: next-parameter ( vreg rep on-stack? -- ) + [ dup dup reg-class-of reg-class-full? ] dip or + [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if + [ 3array ] dip get push ; + : next-return-reg ( rep -- reg ) reg-class-of get pop ; : with-return-regs ( quot -- ) diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index e18c0fa792..29498affc2 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -46,7 +46,7 @@ M: ##phi visit-insn ] if ; M: vreg-insn visit-insn - defs-vreg [ dup record-copy ] when* ; + defs-vregs [ dup record-copy ] each ; M: insn visit-insn drop ; diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index c6b3819fb0..b985fbb27a 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -28,11 +28,11 @@ SYMBOL: allocations GENERIC: build-liveness-graph ( insn -- ) -: add-edges ( insn register -- ) - [ uses-vregs ] dip liveness-graph get [ union ] change-at ; +: add-edges ( uses def -- ) + liveness-graph get [ union ] change-at ; : setter-liveness-graph ( insn vreg -- ) - dup allocation? [ add-edges ] [ 2drop ] if ; + dup allocation? [ [ uses-vregs ] dip add-edges ] [ 2drop ] if ; M: ##set-slot build-liveness-graph dup obj>> setter-liveness-graph ; @@ -50,7 +50,7 @@ M: ##allot build-liveness-graph [ dst>> allocations get adjoin ] [ call-next-method ] bi ; M: vreg-insn build-liveness-graph - dup defs-vreg dup [ add-edges ] [ 2drop ] if ; + [ uses-vregs ] [ defs-vregs ] bi [ add-edges ] with each ; M: insn build-liveness-graph drop ; @@ -83,14 +83,9 @@ M: ##write-barrier compute-live-vregs M: ##write-barrier-imm compute-live-vregs dup src>> setter-live-vregs ; -M: ##fixnum-add compute-live-vregs record-live ; +M: flushable-insn compute-live-vregs drop ; -M: ##fixnum-sub compute-live-vregs record-live ; - -M: ##fixnum-mul compute-live-vregs record-live ; - -M: vreg-insn compute-live-vregs - dup defs-vreg [ drop ] [ record-live ] if ; +M: vreg-insn compute-live-vregs record-live ; M: insn compute-live-vregs drop ; @@ -104,15 +99,9 @@ M: ##write-barrier live-insn? src>> live-vreg? ; M: ##write-barrier-imm live-insn? src>> live-vreg? ; -M: ##fixnum-add live-insn? drop t ; +M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ; -M: ##fixnum-sub live-insn? drop t ; - -M: ##fixnum-mul live-insn? drop t ; - -M: vreg-insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ; - -M: insn live-insn? defs-vreg drop t ; +M: insn live-insn? drop t ; : eliminate-dead-code ( cfg -- cfg' ) ! Even though we don't use predecessors directly, we depend diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index dc0be45cc0..fd0a0be7d9 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -121,7 +121,7 @@ M: rs-loc pprint* \ R pprint-loc ; post-order [ instructions>> [ [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ] - [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ] - bi [ suffix ] when* + [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ] + bi append ] map concat ] map concat >hashtable representations set ; diff --git a/basis/compiler/cfg/def-use/def-use-tests.factor b/basis/compiler/cfg/def-use/def-use-tests.factor index a4f0819397..681e0fd74f 100644 --- a/basis/compiler/cfg/def-use/def-use-tests.factor +++ b/basis/compiler/cfg/def-use/def-use-tests.factor @@ -33,4 +33,4 @@ V{ 5 6 edge cfg new 1 get >>entry 0 set -[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test +[ ] [ 0 get compute-defs ] unit-test diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index a2a0b2d8be..bfbf13e1a9 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -9,16 +9,14 @@ FROM: namespaces => set ; FROM: sets => members ; IN: compiler.cfg.def-use -GENERIC: defs-vreg ( insn -- vreg/f ) +GENERIC: defs-vregs ( insn -- seq ) GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -M: insn defs-vreg drop f ; +M: insn defs-vregs drop { } ; M: insn temp-vregs drop { } ; M: insn uses-vregs drop { } ; -M: ##phi uses-vregs inputs>> values ; - > values ; [ '[ _ cleave _ narray ] ] } case ; -: define-defs-vreg-method ( insn -- ) - dup insn-def-slot dup [ - [ \ defs-vreg create-method ] - [ name>> reader-word 1quotation ] bi* +: define-vregs-method ( insn slots word -- ) + [ [ drop ] ] dip '[ + [ _ create-method ] + [ [ name>> ] map slot-array-quot ] bi* define - ] [ 2drop ] if ; + ] if-empty ; inline + +: define-defs-vregs-method ( insn -- ) + dup insn-def-slots \ defs-vregs define-vregs-method ; : define-uses-vregs-method ( insn -- ) - dup insn-use-slots [ drop ] [ - [ \ uses-vregs create-method ] - [ [ name>> ] map slot-array-quot ] bi* - define - ] if-empty ; + dup insn-use-slots \ uses-vregs define-vregs-method ; : define-temp-vregs-method ( insn -- ) - dup insn-temp-slots [ drop ] [ - [ \ temp-vregs create-method ] - [ [ name>> ] map slot-array-quot ] bi* - define - ] if-empty ; + dup insn-temp-slots \ temp-vregs define-vregs-method ; PRIVATE> +CONSTANT: special-vreg-insns +{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs } + +M: ##phi defs-vregs dst>> 1array ; + +M: alien-call-insn defs-vregs + reg-outputs>> [ first ] map ; + +M: ##callback-inputs defs-vregs + [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ; + +M: ##callback-outputs defs-vregs drop { } ; + +M: ##phi uses-vregs inputs>> values ; + +M: alien-call-insn uses-vregs + [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ; + +M: ##alien-indirect uses-vregs + [ call-next-method ] [ src>> ] bi prefix ; + +M: ##callback-inputs uses-vregs + drop { } ; + +M: ##callback-outputs uses-vregs + reg-inputs>> [ first ] map ; + [ insn-classes get - [ [ define-defs-vreg-method ] each ] - [ { ##phi } diff [ define-uses-vregs-method ] each ] + [ special-vreg-insns diff [ define-defs-vregs-method ] each ] + [ special-vreg-insns diff [ define-uses-vregs-method ] each ] [ [ define-temp-vregs-method ] each ] tri ] with-compilation-unit @@ -69,7 +89,7 @@ SYMBOLS: defs insns uses ; : insn-of ( vreg -- insn ) insns get at ; : set-def-of ( obj insn assoc -- ) - swap defs-vreg dup [ swap set-at ] [ 3drop ] if ; + swap defs-vregs [ swap set-at ] with with each ; : compute-defs ( cfg -- ) H{ } clone [ @@ -89,16 +109,3 @@ SYMBOLS: defs insns uses ; ] each ] each-basic-block ] keep insns set ; - -:: compute-uses ( cfg -- ) - ! Here, a phi node uses its argument in the block that it comes from. - H{ } clone :> use - cfg [| block | - block instructions>> [ - dup ##phi? - [ inputs>> [ use adjoin-at ] assoc-each ] - [ uses-vregs [ block swap use adjoin-at ] each ] - if - ] each - ] each-basic-block - use [ members ] assoc-map uses set ; diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index ff9b82208c..bb30e4841d 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -45,7 +45,7 @@ M: node hashcode* nip number>> ; ! we only care about local def-use H{ } clone :> definers nodes [| node | - node insn>> defs-vreg [ node swap definers set-at ] when* + node insn>> defs-vregs [ node swap definers set-at ] each node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each ] each ; diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 9a4947abfb..6103b4c9fa 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -3,7 +3,7 @@ USING: kernel compiler.cfg.gc-checks compiler.cfg.representations compiler.cfg.save-contexts compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame -compiler.cfg.linear-scan compiler.cfg.scheduling +compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.finalization diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index e758ec808d..eab3fce666 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -61,9 +61,7 @@ M: insn gc-check-offsets* 2drop ; GENERIC: allocation-size* ( insn -- n ) M: ##allot allocation-size* size>> ; - M: ##box-alien allocation-size* drop 5 cells ; - M: ##box-displaced-alien allocation-size* drop 5 cells ; : allocation-size ( insns -- n ) diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index a03f1f83bc..bed856ab9b 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -36,7 +36,7 @@ IN: compiler.cfg.hats PRIVATE> insn-classes get [ - dup [ insn-def-slot ] [ name>> "##" head? ] bi and + dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and [ define-hat ] [ drop ] if ] each diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 0e94ab6e6b..1b7aa94fae 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -19,42 +19,46 @@ TUPLE: insn ; ! Instructions which use vregs TUPLE: vreg-insn < insn ; +! Instructions which do not have side effects; used for +! dead code elimination +TUPLE: flushable-insn < vreg-insn ; + ! Instructions which are referentially transparent; used for ! value numbering -TUPLE: pure-insn < vreg-insn ; +TUPLE: foldable-insn < flushable-insn ; ! Constants -INSN: ##load-integer +FOLDABLE-INSN: ##load-integer def: dst/int-rep literal: val ; -INSN: ##load-reference +FOLDABLE-INSN: ##load-reference def: dst/tagged-rep literal: obj ; -! These three are inserted by representation selection -INSN: ##load-tagged +! These four are inserted by representation selection +FLUSHABLE-INSN: ##load-tagged def: dst/tagged-rep literal: val ; -INSN: ##load-float +FLUSHABLE-INSN: ##load-float def: dst/float-rep literal: val ; -INSN: ##load-double +FLUSHABLE-INSN: ##load-double def: dst/double-rep literal: val ; -INSN: ##load-vector +FLUSHABLE-INSN: ##load-vector def: dst literal: val rep ; ! Stack operations -INSN: ##peek +FLUSHABLE-INSN: ##peek def: dst/tagged-rep literal: loc ; -INSN: ##replace +VREG-INSN: ##replace use: src/tagged-rep literal: loc ; @@ -84,750 +88,732 @@ INSN: ##return ; INSN: ##no-tco ; ! Jump tables -INSN: ##dispatch +VREG-INSN: ##dispatch use: src/int-rep temp: temp/int-rep ; ! Slot access -INSN: ##slot +FLUSHABLE-INSN: ##slot def: dst/tagged-rep use: obj/tagged-rep slot/int-rep literal: scale tag ; -INSN: ##slot-imm +FLUSHABLE-INSN: ##slot-imm def: dst/tagged-rep use: obj/tagged-rep literal: slot tag ; -INSN: ##set-slot +VREG-INSN: ##set-slot use: src/tagged-rep obj/tagged-rep slot/int-rep literal: scale tag ; -INSN: ##set-slot-imm +VREG-INSN: ##set-slot-imm use: src/tagged-rep obj/tagged-rep literal: slot tag ; ! Register transfers -INSN: ##copy +FOLDABLE-INSN: ##copy def: dst use: src literal: rep ; -PURE-INSN: ##tagged>integer +FOLDABLE-INSN: ##tagged>integer def: dst/int-rep use: src/tagged-rep ; ! Integer arithmetic -PURE-INSN: ##add +FOLDABLE-INSN: ##add def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##add-imm +FOLDABLE-INSN: ##add-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##sub +FOLDABLE-INSN: ##sub def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##sub-imm +FOLDABLE-INSN: ##sub-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##mul +FOLDABLE-INSN: ##mul def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##mul-imm +FOLDABLE-INSN: ##mul-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##and +FOLDABLE-INSN: ##and def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##and-imm +FOLDABLE-INSN: ##and-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##or +FOLDABLE-INSN: ##or def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##or-imm +FOLDABLE-INSN: ##or-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##xor +FOLDABLE-INSN: ##xor def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##xor-imm +FOLDABLE-INSN: ##xor-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##shl +FOLDABLE-INSN: ##shl def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##shl-imm +FOLDABLE-INSN: ##shl-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##shr +FOLDABLE-INSN: ##shr def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##shr-imm +FOLDABLE-INSN: ##shr-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##sar +FOLDABLE-INSN: ##sar def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##sar-imm +FOLDABLE-INSN: ##sar-imm def: dst/int-rep use: src1/int-rep literal: src2 ; -PURE-INSN: ##min +FOLDABLE-INSN: ##min def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##max +FOLDABLE-INSN: ##max def: dst/int-rep use: src1/int-rep src2/int-rep ; -PURE-INSN: ##not +FOLDABLE-INSN: ##not def: dst/int-rep use: src/int-rep ; -PURE-INSN: ##neg +FOLDABLE-INSN: ##neg def: dst/int-rep use: src/int-rep ; -PURE-INSN: ##log2 +FOLDABLE-INSN: ##log2 def: dst/int-rep use: src/int-rep ; -PURE-INSN: ##bit-count +FOLDABLE-INSN: ##bit-count def: dst/int-rep use: src/int-rep ; ! Float arithmetic -PURE-INSN: ##add-float +FOLDABLE-INSN: ##add-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##sub-float +FOLDABLE-INSN: ##sub-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##mul-float +FOLDABLE-INSN: ##mul-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##div-float +FOLDABLE-INSN: ##div-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##min-float +FOLDABLE-INSN: ##min-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##max-float +FOLDABLE-INSN: ##max-float def: dst/double-rep use: src1/double-rep src2/double-rep ; -PURE-INSN: ##sqrt +FOLDABLE-INSN: ##sqrt def: dst/double-rep use: src/double-rep ; ! libc intrinsics -PURE-INSN: ##unary-float-function +FOLDABLE-INSN: ##unary-float-function def: dst/double-rep use: src/double-rep literal: func ; -PURE-INSN: ##binary-float-function +FOLDABLE-INSN: ##binary-float-function def: dst/double-rep use: src1/double-rep src2/double-rep literal: func ; ! Single/double float conversion -PURE-INSN: ##single>double-float +FOLDABLE-INSN: ##single>double-float def: dst/double-rep use: src/float-rep ; -PURE-INSN: ##double>single-float +FOLDABLE-INSN: ##double>single-float def: dst/float-rep use: src/double-rep ; ! Float/integer conversion -PURE-INSN: ##float>integer +FOLDABLE-INSN: ##float>integer def: dst/int-rep use: src/double-rep ; -PURE-INSN: ##integer>float +FOLDABLE-INSN: ##integer>float def: dst/double-rep use: src/int-rep ; ! SIMD operations -PURE-INSN: ##zero-vector +FOLDABLE-INSN: ##zero-vector def: dst literal: rep ; -PURE-INSN: ##fill-vector +FOLDABLE-INSN: ##fill-vector def: dst literal: rep ; -PURE-INSN: ##gather-vector-2 +FOLDABLE-INSN: ##gather-vector-2 def: dst use: src1/scalar-rep src2/scalar-rep literal: rep ; -PURE-INSN: ##gather-int-vector-2 +FOLDABLE-INSN: ##gather-int-vector-2 def: dst use: src1/int-rep src2/int-rep literal: rep ; -PURE-INSN: ##gather-vector-4 +FOLDABLE-INSN: ##gather-vector-4 def: dst use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep literal: rep ; -PURE-INSN: ##gather-int-vector-4 +FOLDABLE-INSN: ##gather-int-vector-4 def: dst use: src1/int-rep src2/int-rep src3/int-rep src4/int-rep literal: rep ; -PURE-INSN: ##select-vector +FOLDABLE-INSN: ##select-vector def: dst/int-rep use: src literal: n rep ; -PURE-INSN: ##shuffle-vector +FOLDABLE-INSN: ##shuffle-vector def: dst use: src shuffle literal: rep ; -PURE-INSN: ##shuffle-vector-halves-imm +FOLDABLE-INSN: ##shuffle-vector-halves-imm def: dst use: src1 src2 literal: shuffle rep ; -PURE-INSN: ##shuffle-vector-imm +FOLDABLE-INSN: ##shuffle-vector-imm def: dst use: src literal: shuffle rep ; -PURE-INSN: ##tail>head-vector +FOLDABLE-INSN: ##tail>head-vector def: dst use: src literal: rep ; -PURE-INSN: ##merge-vector-head +FOLDABLE-INSN: ##merge-vector-head def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##merge-vector-tail +FOLDABLE-INSN: ##merge-vector-tail def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##float-pack-vector +FOLDABLE-INSN: ##float-pack-vector def: dst use: src literal: rep ; -PURE-INSN: ##signed-pack-vector +FOLDABLE-INSN: ##signed-pack-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##unsigned-pack-vector +FOLDABLE-INSN: ##unsigned-pack-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##unpack-vector-head +FOLDABLE-INSN: ##unpack-vector-head def: dst use: src literal: rep ; -PURE-INSN: ##unpack-vector-tail +FOLDABLE-INSN: ##unpack-vector-tail def: dst use: src literal: rep ; -PURE-INSN: ##integer>float-vector +FOLDABLE-INSN: ##integer>float-vector def: dst use: src literal: rep ; -PURE-INSN: ##float>integer-vector +FOLDABLE-INSN: ##float>integer-vector def: dst use: src literal: rep ; -PURE-INSN: ##compare-vector +FOLDABLE-INSN: ##compare-vector def: dst use: src1 src2 literal: rep cc ; -PURE-INSN: ##test-vector +FOLDABLE-INSN: ##test-vector def: dst/tagged-rep use: src1 temp: temp/int-rep literal: rep vcc ; -INSN: ##test-vector-branch +VREG-INSN: ##test-vector-branch use: src1 temp: temp/int-rep literal: rep vcc ; -PURE-INSN: ##add-vector +FOLDABLE-INSN: ##add-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##saturated-add-vector +FOLDABLE-INSN: ##saturated-add-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##add-sub-vector +FOLDABLE-INSN: ##add-sub-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##sub-vector +FOLDABLE-INSN: ##sub-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##saturated-sub-vector +FOLDABLE-INSN: ##saturated-sub-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##mul-vector +FOLDABLE-INSN: ##mul-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##mul-high-vector +FOLDABLE-INSN: ##mul-high-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##mul-horizontal-add-vector +FOLDABLE-INSN: ##mul-horizontal-add-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##saturated-mul-vector +FOLDABLE-INSN: ##saturated-mul-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##div-vector +FOLDABLE-INSN: ##div-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##min-vector +FOLDABLE-INSN: ##min-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##max-vector +FOLDABLE-INSN: ##max-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##avg-vector +FOLDABLE-INSN: ##avg-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##dot-vector +FOLDABLE-INSN: ##dot-vector def: dst/scalar-rep use: src1 src2 literal: rep ; -PURE-INSN: ##sad-vector +FOLDABLE-INSN: ##sad-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##horizontal-add-vector +FOLDABLE-INSN: ##horizontal-add-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##horizontal-sub-vector +FOLDABLE-INSN: ##horizontal-sub-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##horizontal-shl-vector-imm +FOLDABLE-INSN: ##horizontal-shl-vector-imm def: dst use: src1 literal: src2 rep ; -PURE-INSN: ##horizontal-shr-vector-imm +FOLDABLE-INSN: ##horizontal-shr-vector-imm def: dst use: src1 literal: src2 rep ; -PURE-INSN: ##abs-vector +FOLDABLE-INSN: ##abs-vector def: dst use: src literal: rep ; -PURE-INSN: ##sqrt-vector +FOLDABLE-INSN: ##sqrt-vector def: dst use: src literal: rep ; -PURE-INSN: ##and-vector +FOLDABLE-INSN: ##and-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##andn-vector +FOLDABLE-INSN: ##andn-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##or-vector +FOLDABLE-INSN: ##or-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##xor-vector +FOLDABLE-INSN: ##xor-vector def: dst use: src1 src2 literal: rep ; -PURE-INSN: ##not-vector +FOLDABLE-INSN: ##not-vector def: dst use: src literal: rep ; -PURE-INSN: ##shl-vector-imm +FOLDABLE-INSN: ##shl-vector-imm def: dst use: src1 literal: src2 rep ; -PURE-INSN: ##shr-vector-imm +FOLDABLE-INSN: ##shr-vector-imm def: dst use: src1 literal: src2 rep ; -PURE-INSN: ##shl-vector +FOLDABLE-INSN: ##shl-vector def: dst use: src1 src2/int-scalar-rep literal: rep ; -PURE-INSN: ##shr-vector +FOLDABLE-INSN: ##shr-vector def: dst use: src1 src2/int-scalar-rep literal: rep ; ! Scalar/vector conversion -PURE-INSN: ##scalar>integer +FOLDABLE-INSN: ##scalar>integer def: dst/int-rep use: src literal: rep ; -PURE-INSN: ##integer>scalar +FOLDABLE-INSN: ##integer>scalar def: dst use: src/int-rep literal: rep ; -PURE-INSN: ##vector>scalar +FOLDABLE-INSN: ##vector>scalar def: dst/scalar-rep use: src literal: rep ; -PURE-INSN: ##scalar>vector +FOLDABLE-INSN: ##scalar>vector def: dst use: src/scalar-rep literal: rep ; ! Boxing and unboxing aliens -PURE-INSN: ##box-alien +FOLDABLE-INSN: ##box-alien def: dst/tagged-rep use: src/int-rep temp: temp/int-rep ; -PURE-INSN: ##box-displaced-alien +FOLDABLE-INSN: ##box-displaced-alien def: dst/tagged-rep use: displacement/int-rep base/tagged-rep temp: temp/int-rep literal: base-class ; -PURE-INSN: ##unbox-any-c-ptr +FOLDABLE-INSN: ##unbox-any-c-ptr def: dst/int-rep use: src/tagged-rep ; -PURE-INSN: ##unbox-alien +FOLDABLE-INSN: ##unbox-alien def: dst/int-rep use: src/tagged-rep ; ! Raw memory accessors -INSN: ##load-memory +FLUSHABLE-INSN: ##load-memory def: dst use: base/int-rep displacement/int-rep literal: scale offset rep c-type ; -INSN: ##load-memory-imm +FLUSHABLE-INSN: ##load-memory-imm def: dst use: base/int-rep literal: offset rep c-type ; -INSN: ##store-memory +VREG-INSN: ##store-memory use: src base/int-rep displacement/int-rep literal: scale offset rep c-type ; -INSN: ##store-memory-imm +VREG-INSN: ##store-memory-imm use: src base/int-rep literal: offset rep c-type ; ! Memory allocation -INSN: ##allot +FLUSHABLE-INSN: ##allot def: dst/tagged-rep literal: size class temp: temp/int-rep ; -INSN: ##write-barrier +VREG-INSN: ##write-barrier use: src/tagged-rep slot/int-rep literal: scale tag temp: temp1/int-rep temp2/int-rep ; -INSN: ##write-barrier-imm +VREG-INSN: ##write-barrier-imm use: src/tagged-rep literal: slot tag temp: temp1/int-rep temp2/int-rep ; -INSN: ##alien-global +FLUSHABLE-INSN: ##alien-global def: dst/int-rep literal: symbol library ; -INSN: ##vm-field +FLUSHABLE-INSN: ##vm-field def: dst/tagged-rep literal: offset ; -INSN: ##set-vm-field +VREG-INSN: ##set-vm-field use: src/tagged-rep literal: offset ; ! FFI -INSN: ##stack-frame -literal: stack-frame ; - -INSN: ##unbox +FOLDABLE-INSN: ##unbox def: dst use: src/tagged-rep literal: unboxer rep ; -INSN: ##unbox-long-long +FOLDABLE-INSN: ##unbox-long-long use: src/tagged-rep out/int-rep literal: unboxer ; -INSN: ##store-reg-param -use: src -literal: reg rep ; - -INSN: ##store-stack-param -use: src -literal: n rep ; - -INSN: ##load-reg-param -def: dst -literal: reg rep ; - -INSN: ##load-stack-param -def: dst -literal: n rep ; - -INSN: ##local-allot +FLUSHABLE-INSN: ##local-allot def: dst/int-rep literal: size align offset ; -INSN: ##box +FOLDABLE-INSN: ##box def: dst/tagged-rep use: src literal: boxer rep gc-map ; -INSN: ##box-long-long +FOLDABLE-INSN: ##box-long-long def: dst/tagged-rep use: src1/int-rep src2/int-rep literal: boxer gc-map ; -INSN: ##allot-byte-array +FLUSHABLE-INSN: ##allot-byte-array def: dst/tagged-rep literal: size gc-map ; -INSN: ##prepare-var-args ; +! Alien call inputs and outputs are arrays of triples with shape +! { vreg rep stack#/reg } -INSN: ##alien-invoke -literal: symbols dll gc-map ; +VREG-INSN: ##alien-invoke +literal: reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map ; -INSN: ##cleanup -literal: n ; - -INSN: ##alien-indirect +VREG-INSN: ##alien-indirect use: src/int-rep -literal: gc-map ; +literal: reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map ; -INSN: ##alien-assembly -literal: quot gc-map ; +VREG-INSN: ##alien-assembly +literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ; -INSN: ##begin-callback ; +VREG-INSN: ##callback-inputs +literal: reg-outputs stack-outputs ; INSN: ##alien-callback literal: quot ; -INSN: ##end-callback ; +VREG-INSN: ##callback-outputs +literal: reg-inputs ; ! Control flow -INSN: ##phi +FLUSHABLE-INSN: ##phi def: dst literal: inputs ; INSN: ##branch ; ! Tagged conditionals -INSN: ##compare-branch +VREG-INSN: ##compare-branch use: src1/tagged-rep src2/tagged-rep literal: cc ; -INSN: ##compare-imm-branch +VREG-INSN: ##compare-imm-branch use: src1/tagged-rep literal: src2 cc ; -PURE-INSN: ##compare +FOLDABLE-INSN: ##compare def: dst/tagged-rep use: src1/tagged-rep src2/tagged-rep literal: cc temp: temp/int-rep ; -PURE-INSN: ##compare-imm +FOLDABLE-INSN: ##compare-imm def: dst/tagged-rep use: src1/tagged-rep literal: src2 cc temp: temp/int-rep ; ! Integer conditionals -INSN: ##compare-integer-branch +VREG-INSN: ##compare-integer-branch use: src1/int-rep src2/int-rep literal: cc ; -INSN: ##compare-integer-imm-branch +VREG-INSN: ##compare-integer-imm-branch use: src1/int-rep literal: src2 cc ; -INSN: ##test-branch +VREG-INSN: ##test-branch use: src1/int-rep src2/int-rep literal: cc ; -INSN: ##test-imm-branch +VREG-INSN: ##test-imm-branch use: src1/int-rep literal: src2 cc ; -PURE-INSN: ##compare-integer +FOLDABLE-INSN: ##compare-integer def: dst/tagged-rep use: src1/int-rep src2/int-rep literal: cc temp: temp/int-rep ; -PURE-INSN: ##compare-integer-imm +FOLDABLE-INSN: ##compare-integer-imm def: dst/tagged-rep use: src1/int-rep literal: src2 cc temp: temp/int-rep ; -PURE-INSN: ##test +FOLDABLE-INSN: ##test def: dst/tagged-rep use: src1/int-rep src2/int-rep literal: cc temp: temp/int-rep ; -PURE-INSN: ##test-imm +FOLDABLE-INSN: ##test-imm def: dst/tagged-rep use: src1/int-rep literal: src2 cc temp: temp/int-rep ; ! Float conditionals -INSN: ##compare-float-ordered-branch +VREG-INSN: ##compare-float-ordered-branch use: src1/double-rep src2/double-rep literal: cc ; -INSN: ##compare-float-unordered-branch +VREG-INSN: ##compare-float-unordered-branch use: src1/double-rep src2/double-rep literal: cc ; -PURE-INSN: ##compare-float-ordered +FOLDABLE-INSN: ##compare-float-ordered def: dst/tagged-rep use: src1/double-rep src2/double-rep literal: cc temp: temp/int-rep ; -PURE-INSN: ##compare-float-unordered +FOLDABLE-INSN: ##compare-float-unordered def: dst/tagged-rep use: src1/double-rep src2/double-rep literal: cc temp: temp/int-rep ; ! Overflowing arithmetic -INSN: ##fixnum-add +VREG-INSN: ##fixnum-add def: dst/tagged-rep use: src1/tagged-rep src2/tagged-rep literal: cc ; -INSN: ##fixnum-sub +VREG-INSN: ##fixnum-sub def: dst/tagged-rep use: src1/tagged-rep src2/tagged-rep literal: cc ; -INSN: ##fixnum-mul +VREG-INSN: ##fixnum-mul def: dst/tagged-rep use: src1/tagged-rep src2/int-rep literal: cc ; -INSN: ##save-context +VREG-INSN: ##save-context temp: temp1/int-rep temp2/int-rep ; ! GC checks -INSN: ##check-nursery-branch +VREG-INSN: ##check-nursery-branch literal: size cc temp: temp1/int-rep temp2/int-rep ; -INSN: ##call-gc literal: gc-map ; +INSN: ##call-gc +literal: gc-map ; ! Spills and reloads, inserted by register allocator TUPLE: spill-slot { n integer } ; C: spill-slot -INSN: ##spill +VREG-INSN: ##spill use: src literal: rep dst ; -INSN: ##reload +VREG-INSN: ##reload def: dst literal: rep src ; @@ -878,17 +864,18 @@ TUPLE: gc-map scrub-d scrub-r gc-roots ; : ( -- gc-map ) gc-map new ; +UNION: alien-call-insn +##alien-invoke +##alien-indirect +##alien-assembly ; + ! Instructions that clobber registers. They receive inputs and ! produce outputs in spill slots. UNION: hairy-clobber-insn -##load-reg-param -##store-reg-param ##call-gc -##alien-invoke -##alien-indirect -##alien-assembly -##begin-callback -##end-callback ; +alien-call-insn +##callback-inputs +##callback-outputs ; ! Instructions that clobber registers but are allowed to produce ! outputs in registers. Inputs are in spill slots, except for diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 223ae26b42..16a3ff4158 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -36,11 +36,8 @@ TUPLE: insn-slot-spec type name rep ; ] reduce drop ] { } make ; -: find-def-slot ( slots -- slot/f ) - [ type>> def eq? ] find nip ; - -: insn-def-slot ( class -- slot/f ) - "insn-slots" word-prop find-def-slot ; +: insn-def-slots ( class -- slot/f ) + "insn-slots" word-prop [ type>> def eq? ] filter ; : insn-use-slots ( class -- slots ) "insn-slots" word-prop [ type>> use eq? ] filter ; @@ -59,8 +56,11 @@ TUPLE: insn-slot-spec type name rep ; : vreg-insn-word ( -- word ) "vreg-insn" "compiler.cfg.instructions" lookup ; -: pure-insn-word ( -- word ) - "pure-insn" "compiler.cfg.instructions" lookup ; +: flushable-insn-word ( -- word ) + "flushable-insn" "compiler.cfg.instructions" lookup ; + +: foldable-insn-word ( -- word ) + "foldable-insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) boa-effect in>> but-last { } ; @@ -68,18 +68,14 @@ TUPLE: insn-slot-spec type name rep ; : uses-vregs? ( specs -- ? ) [ type>> { def use temp } member-eq? ] any? ; -: insn-superclass ( pure? specs -- superclass ) - pure-insn-word swap uses-vregs? vreg-insn-word insn-word ? ? ; - -: define-insn-tuple ( class pure? specs -- ) - [ insn-superclass ] keep +: define-insn-tuple ( class superclass specs -- ) [ name>> ] map "insn#" suffix define-tuple-class ; : define-insn-ctor ( class specs -- ) [ dup '[ _ ] [ f ] [ boa , ] surround ] dip [ name>> ] map { } define-declared ; -: define-insn ( class pure? specs -- ) +: define-insn ( class superclass specs -- ) parse-insn-slot-specs { [ nip "insn-slots" set-word-prop ] @@ -89,6 +85,14 @@ TUPLE: insn-slot-spec type name rep ; [ nip define-insn-ctor ] } 3cleave ; -SYNTAX: INSN: CREATE-CLASS f ";" parse-tokens define-insn ; +SYNTAX: INSN: + CREATE-CLASS insn-word ";" parse-tokens define-insn ; -SYNTAX: PURE-INSN: CREATE-CLASS t ";" parse-tokens define-insn ; +SYNTAX: VREG-INSN: + CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ; + +SYNTAX: FLUSHABLE-INSN: + CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ; + +SYNTAX: FOLDABLE-INSN: + CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 722698e789..92f09c650f 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -48,39 +48,59 @@ IN: compiler.cfg.linear-scan.allocation 2dup spill-at-sync-point? [ swap n>> spill f ] [ 2drop t ] if ; -GENERIC: handle-progress* ( obj -- ) +: handle-interval ( live-interval -- ) + [ start>> deactivate-intervals ] + [ start>> activate-intervals ] + [ assign-register ] + tri ; -M: live-interval handle-progress* drop ; - -M: sync-point handle-progress* +: (handle-sync-point) ( sync-point -- ) active-intervals get values [ [ spill-at-sync-point ] with filter! drop ] with each ; -:: handle-progress ( n obj -- ) - n progress set - n deactivate-intervals - obj handle-progress* - n activate-intervals ; +: handle-sync-point ( sync-point -- ) + [ n>> deactivate-intervals ] + [ (handle-sync-point) ] + [ n>> activate-intervals ] + tri ; -GENERIC: handle ( obj -- ) - -M: live-interval handle ( live-interval -- ) - [ [ start>> ] keep handle-progress ] [ assign-register ] bi ; - -M: sync-point handle ( sync-point -- ) - [ n>> ] keep handle-progress ; - -: smallest-heap ( heap1 heap2 -- heap ) - ! If heap1 and heap2 have the same key, favors heap1. +:: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- ) { - { [ dup heap-empty? ] [ drop ] } - { [ over heap-empty? ] [ nip ] } - [ [ [ heap-peek nip ] bi@ <= ] most ] + { + [ unhandled-intervals heap-empty? ] + [ unhandled-sync-points heap-pop drop handle-sync-point ] + } + { + [ unhandled-sync-points heap-empty? ] + [ unhandled-intervals heap-pop drop handle-interval ] + } + [ + unhandled-intervals heap-peek :> ( i ik ) + unhandled-sync-points heap-peek :> ( s sk ) + { + { + [ ik sk < ] + [ unhandled-intervals heap-pop* i handle-interval ] + } + { + [ ik sk > ] + [ unhandled-sync-points heap-pop* s handle-sync-point ] + } + [ + unhandled-intervals heap-pop* + i handle-interval + s (handle-sync-point) + ] + } cond + ] } cond ; -: (allocate-registers) ( -- ) - unhandled-intervals get unhandled-sync-points get smallest-heap - dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ; +: (allocate-registers) ( unhandled-intervals unhandled-sync-points -- ) + 2dup [ heap-empty? ] both? [ 2drop ] [ + [ (allocate-registers-step) ] + [ (allocate-registers) ] + 2bi + ] if ; : finish-allocation ( -- ) active-intervals inactive-intervals @@ -89,6 +109,6 @@ M: sync-point handle ( sync-point -- ) : allocate-registers ( live-intervals sync-point machine-registers -- live-intervals ) init-allocator init-unhandled - (allocate-registers) + unhandled-intervals get unhandled-sync-points get (allocate-registers) finish-allocation handled-intervals get ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index e0cc80f15c..827b878d68 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -90,6 +90,7 @@ ERROR: register-already-used live-interval ; ! Any active intervals which have ended are moved to handled ! Any active intervals which cover the current position ! are moved to inactive + dup progress set active-intervals { { [ 2dup finished? ] [ finish ] } { [ 2dup covers? not ] [ deactivate ] } diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 65f341feb8..665ffc324d 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -54,8 +54,11 @@ M: live-interval covers? ( insn# live-interval -- ? ) covers? ] if ; +: (find-use) ( insn# live-interval -- vreg-use ) + uses>> [ n>> <=> ] with search nip ; + :: find-use ( insn# live-interval -- vreg-use ) - insn# live-interval uses>> [ n>> <=> ] with search nip + insn# live-interval (find-use) dup [ dup n>> insn# = [ drop f ] unless ] when ; : add-new-range ( from to live-interval -- ) @@ -122,7 +125,7 @@ M: insn compute-live-intervals* drop ; M: vreg-insn compute-live-intervals* ( insn -- ) dup insn#>> - [ [ defs-vreg ] dip '[ _ record-def ] when* ] + [ [ defs-vregs ] dip '[ _ record-def ] each ] [ [ uses-vregs ] dip '[ _ record-use ] each ] [ [ temp-vregs ] dip '[ _ record-temp ] each ] 2tri ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index ef12e8323f..cbf4105392 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -16,7 +16,7 @@ BACKWARD-ANALYSIS: live GENERIC: visit-insn ( live-set insn -- live-set ) : kill-defs ( live-set insn -- live-set ) - defs-vreg [ over delete-at ] when* ; inline + defs-vregs [ over delete-at ] each ; inline : gen-uses ( live-set insn -- live-set ) uses-vregs [ over conjoin ] each ; inline diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index 261aab6c54..1b7f6d5f0c 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry functors generic.parser kernel lexer namespaces parser sequences slots words sets @@ -22,22 +22,43 @@ GENERIC: rename-insn-defs ( insn -- ) M: insn rename-insn-defs drop ; -insn-classes get [ insn-def-slot ] filter [ +insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [ [ \ rename-insn-defs create-method-in ] - [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi + [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi define ] each +M: ##phi rename-insn-defs DEF-QUOT change-dst drop ; + +M: alien-call-insn rename-insn-defs + [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ; + +M: ##callback-inputs rename-insn-defs + [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs + [ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs + drop ; + GENERIC: rename-insn-uses ( insn -- ) M: insn rename-insn-uses drop ; -insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [ +insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [ [ \ rename-insn-uses create-method-in ] [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi define ] each +M: alien-call-insn rename-insn-uses + [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs + [ [ first3 USE-QUOT 2dip 3array ] map ] change-stack-inputs + drop ; + +M: ##alien-indirect rename-insn-uses + USE-QUOT change-src call-next-method ; + +M: ##callback-outputs rename-insn-uses + [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ; + M: ##phi rename-insn-uses [ USE-QUOT assoc-map ] change-inputs drop ; diff --git a/basis/compiler/cfg/representations/coalescing/coalescing.factor b/basis/compiler/cfg/representations/coalescing/coalescing.factor index 20610649bc..6e31e82201 100644 --- a/basis/compiler/cfg/representations/coalescing/coalescing.factor +++ b/basis/compiler/cfg/representations/coalescing/coalescing.factor @@ -12,7 +12,7 @@ SYMBOL: components : init-components ( cfg components -- ) '[ instructions>> [ - defs-vreg [ _ add-atom ] when* + defs-vregs [ _ add-atom ] each ] each ] each-basic-block ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 8ca91c4389..66b29aca34 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -1,19 +1,20 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays fry namespaces generic words sets combinators generalizations sequences.generalizations cpu.architecture compiler.units compiler.cfg.utilities compiler.cfg compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.def-use ; -FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ; +FROM: compiler.cfg.instructions.syntax => insn-def-slots +insn-use-slots insn-temp-slots scalar-rep ; FROM: namespaces => set ; IN: compiler.cfg.representations.preferred -GENERIC: defs-vreg-rep ( insn -- rep/f ) +GENERIC: defs-vreg-reps ( insn -- reps ) GENERIC: temp-vreg-reps ( insn -- reps ) GENERIC: uses-vreg-reps ( insn -- reps ) -M: insn defs-vreg-rep drop f ; +M: insn defs-vreg-reps drop { } ; M: insn temp-vreg-reps drop { } ; M: insn uses-vreg-reps drop { } ; @@ -26,13 +27,6 @@ M: insn uses-vreg-reps drop { } ; [ [ drop ] swap suffix ] } case ; -: define-defs-vreg-rep-method ( insn -- ) - dup insn-def-slot dup [ - [ \ defs-vreg-rep create-method ] - [ rep>> rep-getter-quot ] - bi* define - ] [ 2drop ] if ; - : reps-getter-quot ( reps -- quot ) dup [ rep>> { f scalar-rep } member-eq? not ] all? [ [ rep>> ] map [ drop ] swap suffix @@ -45,32 +39,54 @@ M: insn uses-vreg-reps drop { } ; } case ] if ; -: define-uses-vreg-reps-method ( insn -- ) - dup insn-use-slots [ drop ] [ - [ \ uses-vreg-reps create-method ] +: define-vreg-reps-method ( insn slots word -- ) + [ [ drop ] ] dip '[ + [ _ create-method ] [ reps-getter-quot ] bi* define ] if-empty ; +: define-defs-vreg-reps-method ( insn -- ) + dup insn-def-slots \ defs-vreg-reps define-vreg-reps-method ; + +: define-uses-vreg-reps-method ( insn -- ) + dup insn-use-slots \ uses-vreg-reps define-vreg-reps-method ; + : define-temp-vreg-reps-method ( insn -- ) - dup insn-temp-slots [ drop ] [ - [ \ temp-vreg-reps create-method ] - [ reps-getter-quot ] - bi* define - ] if-empty ; + dup insn-temp-slots \ temp-vreg-reps define-vreg-reps-method ; PRIVATE> +M: alien-call-insn defs-vreg-reps + reg-outputs>> [ second ] map ; + +M: ##callback-inputs defs-vreg-reps + [ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ; + +M: ##callback-outputs defs-vreg-reps drop { } ; + +M: alien-call-insn uses-vreg-reps + [ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ; + +M: ##alien-indirect uses-vreg-reps + call-next-method int-rep prefix ; + +M: ##callback-inputs uses-vreg-reps + drop { } ; + +M: ##callback-outputs uses-vreg-reps + reg-inputs>> [ second ] map ; + [ insn-classes get - [ [ define-defs-vreg-rep-method ] each ] - [ { ##phi } diff [ define-uses-vreg-reps-method ] each ] + [ special-vreg-insns diff [ define-defs-vreg-reps-method ] each ] + [ special-vreg-insns diff [ define-uses-vreg-reps-method ] each ] [ [ define-temp-vreg-reps-method ] each ] tri ] with-compilation-unit : each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- ) - [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline + [ [ defs-vregs ] [ defs-vreg-reps ] bi ] dip 2each ; inline : each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- ) [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline @@ -80,12 +96,3 @@ PRIVATE> : each-rep ( insn vreg-quot: ( vreg rep -- ) -- ) [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline - -: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- ) - '[ - [ basic-block set ] [ - [ - _ each-rep - ] each-non-phi - ] bi - ] each-basic-block ; inline diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor index 9955814ed9..c733dba5ed 100644 --- a/basis/compiler/cfg/representations/representations-tests.factor +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -16,13 +16,13 @@ IN: compiler.cfg.representations } uses-vreg-reps ] unit-test -[ double-rep ] [ +[ { double-rep } ] [ T{ ##load-memory-imm { dst 5 } { base 3 } { offset 0 } { rep double-rep } - } defs-vreg-rep + } defs-vreg-reps ] unit-test H{ } clone representations set diff --git a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor index 8dd267fd44..e074d95b1a 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor @@ -44,10 +44,6 @@ V{ V{ T{ ##inc-d f 3 } - T{ ##load-reg-param f 0 RCX int-rep } - T{ ##load-reg-param f 1 RDX int-rep } - T{ ##load-reg-param f 2 R8 int-rep } - T{ ##begin-callback } T{ ##box f 4 3 "from_signed_4" int-rep T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } } } @@ -58,11 +54,7 @@ V{ [ V{ T{ ##inc-d f 3 } - T{ ##load-reg-param f 0 RCX int-rep } - T{ ##load-reg-param f 1 RDX int-rep } - T{ ##load-reg-param f 2 R8 int-rep } T{ ##save-context f 5 6 } - T{ ##begin-callback } T{ ##box f 4 3 "from_signed_4" int-rep T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } } } diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index fa37a516a7..e20cb68020 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -20,7 +20,7 @@ GENERIC: modifies-context? ( insn -- ? ) M: ##inc-d modifies-context? drop t ; M: ##inc-r modifies-context? drop t ; -M: ##load-reg-param modifies-context? drop t ; +M: ##callback-inputs modifies-context? drop t ; M: insn modifies-context? drop f ; : save-context-offset ( bb -- n ) diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index 526587dabe..70e088e500 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -32,11 +32,15 @@ SYMBOL: defs ! Set of vregs defined in more than one basic block SYMBOL: defs-multi -: compute-insn-defs ( bb insn -- ) - defs-vreg dup [ +GENERIC: compute-insn-defs ( bb insn -- ) + +M: insn compute-insn-defs 2drop ; + +M: vreg-insn compute-insn-defs + defs-vregs [ defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri [ defs-multi get conjoin ] [ drop ] if - ] [ 2drop ] if ; + ] with each ; : compute-defs ( cfg -- ) H{ } clone defs set diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index 06ae6767ca..ed2046bdaa 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel locals fry sequences +USING: accessors assocs kernel locals fry sequences sets cpu.architecture compiler.cfg.rpo compiler.cfg.def-use @@ -18,7 +18,7 @@ IN: compiler.cfg.ssa.cssa ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't ! need to insert a copy since in fact doing so will result ! in incorrect code. - [ instructions>> last defs-vreg ] dip eq? not ; + [ instructions>> last defs-vregs ] dip swap in? not ; :: insert-copy ( bb src rep -- bb dst ) bb src insert-copy? [ diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 1bb19bd8b0..bd5a84afc7 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -47,7 +47,7 @@ SYMBOL: class-element-map SYMBOL: copies : value-of ( vreg -- value ) - insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ; + dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ; : init-coalescing ( -- ) defs get @@ -85,9 +85,9 @@ M: insn prepare-insn drop ; M: vreg-insn prepare-insn [ temp-vregs [ leader-map get conjoin ] each ] [ - [ defs-vreg ] [ uses-vregs ] bi - 2dup empty? not and [ - first + [ defs-vregs ] [ uses-vregs ] bi + 2dup [ empty? not ] both? [ + [ first ] bi@ 2dup [ rep-of reg-class-of ] bi@ eq? [ maybe-eliminate-copy-later ] [ 2drop ] if ] [ 2drop ] if diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index d0c729556d..d301b14996 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -12,26 +12,26 @@ IN: compiler.cfg.ssa.interference.live-ranges SYMBOLS: local-def-indices local-kill-indices ; -: record-def ( n insn -- ) - defs-vreg dup [ local-def-indices get set-at ] [ 2drop ] if ; +: record-defs ( n insn -- ) + defs-vregs [ local-def-indices get set-at ] with each ; : record-uses ( n insn -- ) ! Record live intervals so that all but the first input interfere ! with the output. This lets us coalesce the output with the ! first input. - dup uses-vregs dup empty? [ 3drop ] [ + dup uses-vregs [ 2drop ] [ swap def-is-use-insn? [ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless [ 1 + ] dip [ local-kill-indices get set-at ] with each - ] if ; + ] if-empty ; GENERIC: record-insn ( n insn -- ) M: ##phi record-insn - record-def ; + record-defs ; M: vreg-insn record-insn - [ 2 * ] dip [ record-def ] [ record-uses ] 2bi ; + [ 2 * ] dip [ record-defs ] [ record-uses ] 2bi ; M: insn record-insn 2drop ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 46e5a09907..411f682c77 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes classes.algebra combinators fry generic.parser kernel math namespaces quotations sequences slots -words make +words make sets compiler.cfg.instructions compiler.cfg.instructions.syntax compiler.cfg.value-numbering.graph ; @@ -49,7 +49,8 @@ GENERIC: >expr ( insn -- expr ) [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ; insn-classes get -[ pure-insn class<= ] filter +[ foldable-insn class<= ] filter +{ ##copy ##load-integer ##load-reference } diff [ dup "insn-slots" word-prop input-values define->expr-method diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 23fae4932e..2418a67eae 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -36,9 +36,12 @@ GENERIC: process-instruction ( insn -- insn' ) [ redundant-instruction ] [ useful-instruction ] ?if ; M: insn process-instruction + dup rewrite [ process-instruction ] [ ] ?if ; + +M: foldable-insn process-instruction dup rewrite [ process-instruction ] - [ dup defs-vreg [ check-redundancy ] when ] ?if ; + [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ; M: ##copy process-instruction dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 703d8126e0..654d676ad1 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -91,8 +91,6 @@ M: ##dispatch generate-insn ! Special cases M: ##no-tco generate-insn drop ; -M: ##stack-frame generate-insn drop ; - M: ##prologue generate-insn drop cfg get stack-frame>> @@ -287,21 +285,13 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul ! FFI CODEGEN: ##unbox %unbox CODEGEN: ##unbox-long-long %unbox-long-long -CODEGEN: ##store-reg-param %store-reg-param -CODEGEN: ##store-stack-param %store-stack-param -CODEGEN: ##load-reg-param %load-reg-param -CODEGEN: ##load-stack-param %load-stack-param CODEGEN: ##local-allot %local-allot CODEGEN: ##box %box CODEGEN: ##box-long-long %box-long-long CODEGEN: ##allot-byte-array %allot-byte-array -CODEGEN: ##prepare-var-args %prepare-var-args CODEGEN: ##alien-invoke %alien-invoke -CODEGEN: ##cleanup %cleanup CODEGEN: ##alien-indirect %alien-indirect -CODEGEN: ##begin-callback %begin-callback +CODEGEN: ##alien-assembly %alien-assembly +CODEGEN: ##callback-inputs %callback-inputs CODEGEN: ##alien-callback %alien-callback -CODEGEN: ##end-callback %end-callback - -M: ##alien-assembly generate-insn - [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ; +CODEGEN: ##callback-outputs %callback-outputs diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index f81ac8f52a..277896130e 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -587,10 +587,6 @@ HOOK: %unbox cpu ( dst src func rep -- ) HOOK: %unbox-long-long cpu ( src out func -- ) -HOOK: %store-reg-param cpu ( src reg rep -- ) - -HOOK: %store-stack-param cpu ( src n rep -- ) - HOOK: %local-allot cpu ( dst size align offset -- ) ! Call a function to convert a value into a tagged pointer, @@ -604,28 +600,18 @@ HOOK: %allot-byte-array cpu ( dst size gc-map -- ) HOOK: %save-context cpu ( temp1 temp2 -- ) -HOOK: %prepare-var-args cpu ( -- ) +HOOK: %c-invoke cpu ( symbols dll gc-map -- ) -M: object %prepare-var-args ; +HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- ) -HOOK: %alien-invoke cpu ( function library gc-map -- ) +HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- ) -HOOK: %cleanup cpu ( n -- ) +HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- ) -M: object %cleanup ( n -- ) drop ; - -HOOK: %alien-indirect cpu ( src gc-map -- ) - -HOOK: %load-reg-param cpu ( dst reg rep -- ) - -HOOK: %load-stack-param cpu ( dst n rep -- ) - -HOOK: %begin-callback cpu ( -- ) +HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- ) HOOK: %alien-callback cpu ( quot -- ) -HOOK: %end-callback cpu ( -- ) +HOOK: %callback-outputs cpu ( reg-inputs -- ) HOOK: stack-cleanup cpu ( stack-size return abi -- n ) - -M: object stack-cleanup 3drop 0 ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 56ec02d851..7fcce4ccfd 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -230,13 +230,13 @@ M: integer float-function-param* FMR ; M:: ppc %unary-float-function ( dst src func -- ) 0 src float-function-param - func f %alien-invoke + func f %c-invoke dst float-function-return ; M:: ppc %binary-float-function ( dst src1 src2 func -- ) 0 src1 float-function-param 1 src2 float-function-param - func f %alien-invoke + func f %c-invoke dst float-function-return ; ! Internal format is always double-precision on PowerPC @@ -513,7 +513,7 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- ) M: ppc %call-gc ( gc-roots -- ) 3 swap gc-root-offsets %load-reference 4 %load-vm-addr - "inline_gc" f %alien-invoke ; + "inline_gc" f %c-invoke ; M: ppc %prologue ( n -- ) 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this @@ -689,7 +689,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ; :: call-unbox-func ( src func -- ) 3 src load-param 4 %load-vm-addr - func f %alien-invoke ; + func f %c-invoke ; M:: ppc %unbox ( src n rep func -- ) src func call-unbox-func @@ -708,12 +708,12 @@ M:: ppc %unbox-large-struct ( src n c-type -- ) 4 src load-param 3 1 n local@ ADDI c-type heap-size 5 LI - "memcpy" "libc" load-library %alien-invoke ; + "memcpy" "libc" load-library %c-invoke ; M:: ppc %box ( dst n rep func -- ) n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when* rep double-rep? 5 4 ? %load-vm-addr - func f %alien-invoke + func f %c-invoke 3 dst store-param ; M:: ppc %box-long-long ( dst n func -- ) @@ -722,7 +722,7 @@ M:: ppc %box-long-long ( dst n func -- ) 4 1 n cell + local@ LWZ ] when 5 %load-vm-addr - func f %alien-invoke + func f %c-invoke 3 dst store-param ; : struct-return@ ( n -- n ) @@ -740,7 +740,7 @@ M:: ppc %box-large-struct ( dst n c-type -- ) c-type heap-size 4 LI 5 %load-vm-addr ! Call the function - "from_value_struct" f %alien-invoke + "from_value_struct" f %c-invoke 3 dst store-param ; M:: ppc %restore-context ( temp1 temp2 -- ) @@ -754,7 +754,7 @@ M:: ppc %save-context ( temp1 temp2 -- ) ds-reg temp1 "datastack" context-field-offset STW rs-reg temp1 "retainstack" context-field-offset STW ; -M: ppc %alien-invoke ( symbol dll -- ) +M: ppc %c-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-indirect ( src -- ) @@ -773,7 +773,7 @@ M:: ppc %box-small-struct ( dst c-type -- ) #! Box a <= 16-byte struct returned in r3:r4:r5:r6 c-type heap-size 7 LI 8 %load-vm-addr - "from_medium_struct" f %alien-invoke + "from_medium_struct" f %c-invoke 3 dst store-param ; : %unbox-struct-1 ( -- ) @@ -802,7 +802,7 @@ M:: ppc %unbox-small-struct ( src c-type -- ) M: ppc %begin-callback ( -- ) 3 %load-vm-addr - "begin_callback" f %alien-invoke ; + "begin_callback" f %c-invoke ; M: ppc %alien-callback ( quot -- ) 3 swap %load-reference @@ -812,7 +812,7 @@ M: ppc %alien-callback ( quot -- ) M: ppc %end-callback ( -- ) 3 %load-vm-addr - "end_callback" f %alien-invoke ; + "end_callback" f %c-invoke ; enable-float-functions diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 48cc88a4f8..5de875fb72 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -106,8 +106,8 @@ M: x86.32 %prepare-jump dst ?spill-slot x87-insn execute ] if ; inline -M: x86.32 %load-reg-param ( dst reg rep -- ) - { +M: x86.32 %load-reg-param ( vreg rep reg -- ) + swap { { int-rep [ int-rep %copy ] } { float-rep [ drop \ FSTPS float-rep load-float-return ] } { double-rep [ drop \ FSTPL double-rep load-float-return ] } @@ -123,8 +123,8 @@ M: x86.32 %load-reg-param ( dst reg rep -- ) src ?spill-slot x87-insn execute ] if ; inline -M: x86.32 %store-reg-param ( src reg rep -- ) - { +M: x86.32 %store-reg-param ( vreg rep reg -- ) + swap { { int-rep [ swap int-rep %copy ] } { float-rep [ drop \ FLDS float-rep store-float-return ] } { double-rep [ drop \ FLDL double-rep store-float-return ] } @@ -134,7 +134,7 @@ M: x86.32 %store-reg-param ( src reg rep -- ) EAX src tagged-rep %copy 4 save-vm-ptr 0 stack@ EAX MOV - func f f %alien-invoke ; + func f f %c-invoke ; M:: x86.32 %unbox ( dst src func rep -- ) src func call-unbox-func @@ -146,13 +146,13 @@ M:: x86.32 %unbox-long-long ( src out func -- ) EAX out int-rep %copy 4 stack@ EAX MOV 8 save-vm-ptr - func f f %alien-invoke ; + func f f %c-invoke ; M:: x86.32 %box ( dst src func rep gc-map -- ) rep rep-size save-vm-ptr src rep %store-return 0 stack@ rep %load-return - func f gc-map %alien-invoke + func f gc-map %c-invoke dst EAX tagged-rep %copy ; M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) @@ -161,22 +161,22 @@ M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) 0 stack@ EAX int-rep %copy EAX src2 int-rep %copy 4 stack@ EAX int-rep %copy - func f gc-map %alien-invoke + func f gc-map %c-invoke dst EAX tagged-rep %copy ; M:: x86.32 %allot-byte-array ( dst size gc-map -- ) 4 save-vm-ptr 0 stack@ size MOV - "allot_byte_array" f gc-map %alien-invoke + "allot_byte_array" f gc-map %c-invoke dst EAX tagged-rep %copy ; -M: x86.32 %alien-invoke +M: x86.32 %c-invoke [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr 4 stack@ 0 MOV - "begin_callback" f f %alien-invoke ; + "begin_callback" f f %c-invoke ; M: x86.32 %alien-callback ( quot -- ) [ EAX ] dip %load-reference @@ -184,7 +184,7 @@ M: x86.32 %alien-callback ( quot -- ) M: x86.32 %end-callback ( -- ) 0 save-vm-ptr - "end_callback" f f %alien-invoke ; + "end_callback" f f %c-invoke ; GENERIC: float-function-param ( n dst src -- ) @@ -199,13 +199,13 @@ M:: register float-function-param ( n dst src -- ) M:: x86.32 %unary-float-function ( dst src func -- ) 0 dst src float-function-param - func "libm" load-library f %alien-invoke + func "libm" load-library f %c-invoke dst double-rep %load-return ; M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) 0 dst src1 float-function-param 8 dst src2 float-function-param - func "libm" load-library f %alien-invoke + func "libm" load-library f %c-invoke dst double-rep %load-return ; : funny-large-struct-return? ( return abi -- ? ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 7a5e8a1af3..2dc5fb4e37 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -81,38 +81,38 @@ M: x86.64 %mark-deck dup load-decks-offset [+] card-mark MOV ; -M:: x86.64 %load-reg-param ( dst reg rep -- ) - dst reg rep %copy ; +M:: x86.64 %load-reg-param ( vreg rep reg -- ) + vreg reg rep %copy ; -M:: x86.64 %store-reg-param ( src reg rep -- ) - reg src rep %copy ; +M:: x86.64 %store-reg-param ( vreg rep reg -- ) + reg vreg rep %copy ; M:: x86.64 %unbox ( dst src func rep -- ) param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr - func f f %alien-invoke + func f f %c-invoke dst rep %load-return ; M:: x86.64 %box ( dst src func rep gc-map -- ) 0 rep reg-class-of cdecl param-regs at nth src rep %copy rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr - func f gc-map %alien-invoke + func f gc-map %c-invoke dst int-rep %load-return ; M:: x86.64 %allot-byte-array ( dst size gc-map -- ) param-reg-0 size MOV param-reg-1 %mov-vm-ptr - "allot_byte_array" f gc-map %alien-invoke + "allot_byte_array" f gc-map %c-invoke dst int-rep %load-return ; -M: x86.64 %alien-invoke +M: x86.64 %c-invoke [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip gc-map-here ; M: x86.64 %begin-callback ( -- ) param-reg-0 %mov-vm-ptr param-reg-1 0 MOV - "begin_callback" f f %alien-invoke ; + "begin_callback" f f %c-invoke ; M: x86.64 %alien-callback ( quot -- ) [ param-reg-0 ] dip %load-reference @@ -120,14 +120,14 @@ M: x86.64 %alien-callback ( quot -- ) M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr - "end_callback" f f %alien-invoke ; + "end_callback" f f %c-invoke ; : float-function-param ( i src -- ) [ float-regs cdecl param-regs at nth ] dip double-rep %copy ; M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param - func "libm" load-library f %alien-invoke + func "libm" load-library f %c-invoke dst double-rep %load-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) @@ -135,9 +135,13 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! src2 is always a spill slot 0 src1 float-function-param 1 src2 float-function-param - func "libm" load-library f %alien-invoke + func "libm" load-library f %c-invoke dst double-rep %load-return ; +M: x86.64 stack-cleanup 3drop 0 ; + +M: x86.64 %cleanup 0 assert= ; + M: x86.64 long-long-on-stack? f ; M: x86.64 float-on-stack? f ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index cb48438240..722ad0d0f0 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -587,14 +587,8 @@ M:: x86 %spill ( src rep dst -- ) M:: x86 %reload ( dst rep src -- ) dst src rep %copy ; -M:: x86 %store-stack-param ( src n rep -- ) - n reserved-stack-space + stack@ src rep %copy ; - -: %load-return ( dst rep -- ) - [ reg-class-of return-regs at first ] keep %load-reg-param ; - -: %store-return ( dst rep -- ) - [ reg-class-of return-regs at first ] keep %store-reg-param ; +M:: x86 %local-allot ( dst size align offset -- ) + dst offset local-allot-offset special-offset stack@ LEA ; : next-stack@ ( n -- operand ) #! nth parameter from the next stack frame. Used to box @@ -603,14 +597,62 @@ M:: x86 %store-stack-param ( src n rep -- ) #! set up by the caller. [ frame-reg ] dip 2 cells + reserved-stack-space + [+] ; -M:: x86 %load-stack-param ( dst n rep -- ) - dst n next-stack@ rep %copy ; +: return-reg ( rep -- reg ) + reg-class-of return-regs at first ; -M:: x86 %local-allot ( dst size align offset -- ) - dst offset local-allot-offset special-offset stack@ LEA ; +:: %load-stack-param ( dst rep n -- ) + rep return-reg n next-stack@ rep %copy + dst rep return-reg rep %copy ; -M: x86 %alien-indirect ( src gc-map -- ) - [ ?spill-slot CALL ] [ gc-map-here ] bi* ; +:: %store-stack-param ( src rep n -- ) + rep return-reg src rep %copy + n reserved-stack-space + stack@ rep return-reg rep %copy ; + +HOOK: %load-reg-param cpu ( vreg rep reg -- ) + +HOOK: %store-reg-param cpu ( vreg rep reg -- ) + +: %load-return ( dst rep -- ) + dup return-reg %load-reg-param ; + +: %store-return ( dst rep -- ) + dup return-reg %store-reg-param ; + +HOOK: %prepare-var-args cpu ( -- ) + +HOOK: %cleanup cpu ( n -- ) + +:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- ) + stack-inputs [ first3 %store-stack-param ] each + reg-inputs [ first3 %store-reg-param ] each + quot call + cleanup %cleanup + reg-outputs [ first3 %load-reg-param ] each ; inline + +M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- ) + '[ _ _ _ %c-invoke ] emit-alien-insn ; + +M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- ) + reg-inputs stack-inputs reg-outputs cleanup stack-size [ + src ?spill-slot CALL + gc-map gc-map-here + ] emit-alien-insn ; + +M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- ) + '[ _ _ gc-map set call( -- ) ] emit-alien-insn ; + +HOOK: %begin-callback cpu ( -- ) + +M: x86 %callback-inputs ( reg-outputs stack-outputs -- ) + [ [ first3 %load-reg-param ] each ] + [ [ first3 %load-stack-param ] each ] bi* + %begin-callback ; + +HOOK: %end-callback cpu ( -- ) + +M: x86 %callback-outputs ( reg-inputs -- ) + %end-callback + [ first3 %store-reg-param ] each ; M: x86 %loop-entry 16 alignment [ NOP ] times ; @@ -655,20 +697,20 @@ M: x86 immediate-bitwise? ( n -- ? ) :: (%compare-float) ( dst src1 src2 cc temp compare -- ) cc { - { cc< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] } - { cc<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] } - { cc> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] } - { cc>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] } - { cc= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] } - { cc<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] } - { cc<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] } - { cc/< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] } - { cc/<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] } - { cc/> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] } - { cc/>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] } - { cc/= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] } - { cc/<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVE (%boolean) ] } - { cc/<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVP (%boolean) ] } + { cc< [ src2 src1 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] } + { cc<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] } + { cc> [ src1 src2 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] } + { cc>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] } + { cc= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] } + { cc<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] } + { cc<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] } + { cc/< [ src2 src1 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] } + { cc/<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] } + { cc/> [ src1 src2 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] } + { cc/>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] } + { cc/= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] } + { cc/<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVE (%boolean) ] } + { cc/<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVP (%boolean) ] } } case ; inline : %jump-float= ( label -- ) @@ -684,20 +726,20 @@ M: x86 immediate-bitwise? ( n -- ? ) :: (%compare-float-branch) ( label src1 src2 cc compare -- ) cc { - { cc< [ src2 src1 \ compare call( a b -- ) label JA ] } - { cc<= [ src2 src1 \ compare call( a b -- ) label JAE ] } - { cc> [ src1 src2 \ compare call( a b -- ) label JA ] } - { cc>= [ src1 src2 \ compare call( a b -- ) label JAE ] } - { cc= [ src1 src2 \ compare call( a b -- ) label %jump-float= ] } - { cc<> [ src1 src2 \ compare call( a b -- ) label JNE ] } - { cc<>= [ src1 src2 \ compare call( a b -- ) label JNP ] } - { cc/< [ src2 src1 \ compare call( a b -- ) label JBE ] } - { cc/<= [ src2 src1 \ compare call( a b -- ) label JB ] } - { cc/> [ src1 src2 \ compare call( a b -- ) label JBE ] } - { cc/>= [ src1 src2 \ compare call( a b -- ) label JB ] } - { cc/= [ src1 src2 \ compare call( a b -- ) label %jump-float/= ] } - { cc/<> [ src1 src2 \ compare call( a b -- ) label JE ] } - { cc/<>= [ src1 src2 \ compare call( a b -- ) label JP ] } + { cc< [ src2 src1 compare call( a b -- ) label JA ] } + { cc<= [ src2 src1 compare call( a b -- ) label JAE ] } + { cc> [ src1 src2 compare call( a b -- ) label JA ] } + { cc>= [ src1 src2 compare call( a b -- ) label JAE ] } + { cc= [ src1 src2 compare call( a b -- ) label %jump-float= ] } + { cc<> [ src1 src2 compare call( a b -- ) label JNE ] } + { cc<>= [ src1 src2 compare call( a b -- ) label JNP ] } + { cc/< [ src2 src1 compare call( a b -- ) label JBE ] } + { cc/<= [ src2 src1 compare call( a b -- ) label JB ] } + { cc/> [ src1 src2 compare call( a b -- ) label JBE ] } + { cc/>= [ src1 src2 compare call( a b -- ) label JB ] } + { cc/= [ src1 src2 compare call( a b -- ) label %jump-float/= ] } + { cc/<> [ src1 src2 compare call( a b -- ) label JE ] } + { cc/<>= [ src1 src2 compare call( a b -- ) label JP ] } } case ; enable-min/max