From 1625768a9e00ceecd4223514f02d543dbc986fdb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 12 Jul 2010 09:36:36 -0700 Subject: [PATCH 01/18] tools.test: change unit-test docs so it's clear "output" is a sequence and not an executable quotation (reported by mncharity) --- basis/tools/test/test-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index 5aaaa24dc6..e1e9068722 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -53,7 +53,7 @@ $nl ABOUT: "tools.test" HELP: unit-test -{ $syntax "[ output ] [ input ] unit-test" } +{ $syntax "{ output } [ input ] unit-test" } { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; From e27adb2830c7596390548726fabe7b37c5130862 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 Jul 2010 07:40:14 -0400 Subject: [PATCH 02/18] 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 From 73833ebb18a1758fb1c302c484480feab2ea547c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 Jul 2010 17:36:14 -0400 Subject: [PATCH 03/18] gdbm.ffi: fix add-library form --- extra/gdbm/ffi/ffi.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/gdbm/ffi/ffi.factor b/extra/gdbm/ffi/ffi.factor index f2c866769e..e7b02ed2aa 100644 --- a/extra/gdbm/ffi/ffi.factor +++ b/extra/gdbm/ffi/ffi.factor @@ -4,10 +4,10 @@ USING: alien alien.c-types alien.libraries alien.syntax classes.struct combinators system ; IN: gdbm.ffi -<< "libgdbm" os { - { [ unix? ] [ "libgdbm.so" ] } - { [ winnt? ] [ "gdbm.dll" ] } - { [ macosx? ] [ "libgdbm.dylib" ] } +<< "libgdbm" { + { [ os macosx? ] [ "libgdbm.dylib" ] } + { [ os unix? ] [ "libgdbm.so" ] } + { [ os winnt? ] [ "gdbm.dll" ] } } cond cdecl add-library >> LIBRARY: libgdbm From 37bddfba54f2b5d6bf4470cf099f2edf6e5abb03 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 14 Jul 2010 09:09:57 -0700 Subject: [PATCH 04/18] math.combinatorics: all-subsets and selections words (contributed by John Benediktsson) --- .../combinatorics/combinatorics-docs.factor | 26 +++++++++++++++++++ .../combinatorics/combinatorics-tests.factor | 17 ++++++++++++ basis/math/combinatorics/combinatorics.factor | 25 ++++++++++++++++-- 3 files changed, 66 insertions(+), 2 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 0a2a0d4011..75a54c2300 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -103,3 +103,29 @@ HELP: >permutation { $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } } { $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; +HELP: all-subsets +{ $values { "seq" sequence } { "subsets" sequence } } +{ $description + "Returns all the subsets of a sequence." +} +{ $examples + { $example + "USING: math.combinatorics prettyprint ;" + "{ 1 2 3 } all-subsets ." + "{ { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } }" + } +} ; + +HELP: selections +{ $values { "seq" sequence } { "n" integer } { "selections" sequence } } +{ $description + "Returns all the ways to take n (possibly the same) items from the " + "sequence of items." +} +{ $examples + { $example + "USING: math.combinatorics prettyprint ;" + "{ 1 2 } 2 selections ." + "{ { 1 1 } { 1 2 } { 2 1 } { 2 2 } }" + } +} ; diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index bbf5a1cb85..8a551bfe9d 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -70,3 +70,20 @@ IN: math.combinatorics.tests [ { { "a" "b" } { "a" "c" } { "a" "d" } { "b" "c" } { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test + +[ { { } } ] [ { } all-subsets ] unit-test + +[ { { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } } ] +[ { 1 2 3 } all-subsets ] unit-test + +[ { } ] [ { 1 2 } 0 selections ] unit-test + +[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test + +[ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ] +[ { 1 2 } 2 selections ] unit-test + +[ { { 1 1 1 } { 1 1 2 } { 1 2 1 } { 1 2 2 } + { 2 1 1 } { 2 1 2 } { 2 2 1 } { 2 2 2 } } ] +[ { 1 2 } 3 selections ] unit-test + diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 5a9f627015..b69867fb12 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,8 @@ -! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs binary-search fry kernel locals math math.order - math.ranges namespaces sequences sorting ; + math.ranges namespaces sequences sorting make sequences.deep arrays + combinators ; IN: math.combinatorics : reduce-combinations ( seq k identity quot -- result ) [ -rot ] dip each-combination ; inline + +: all-subsets ( seq -- subsets ) + dup length [0,b] [ + [ dupd all-combinations [ , ] each ] each + ] { } make nip ; + +: (selections) ( seq n -- selections ) + dupd [ dup 1 > ] [ + swap pick cartesian-product [ + [ [ dup length 1 > [ flatten ] when , ] each ] each + ] { } make swap 1 - + ] while drop nip ; + +: selections ( seq n -- selections ) + { + { 0 [ drop { } ] } + { 1 [ 1array ] } + [ (selections) ] + } case ; + From 867530223c0981b5d64a413403dc80b30af9f8c2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 Jul 2010 17:47:21 -0400 Subject: [PATCH 05/18] cpu.x86: fix %load/store-stack-param for 32-bit --- basis/cpu/x86/32/32.factor | 18 ++++++++++++++++-- basis/cpu/x86/64/64.factor | 8 ++++++++ basis/cpu/x86/x86.factor | 8 ++------ 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 5de875fb72..379c9c697f 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -96,6 +96,20 @@ M: x86.32 %prologue ( n -- ) M: x86.32 %prepare-jump pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; +M: x86.32 %load-stack-param ( dst rep n -- ) + next-stack@ swap { + { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } + { float-rep [ FLDS ?spill-slot FSTPS ] } + { double-rep [ FLDL ?spill-slot FSTPL ] } + } case ; + +M: x86.32 %store-stack-param ( src rep n -- ) + reserved-stack-space + stack@ swap { + { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } + { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] } + { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] } + } case ; + :: load-float-return ( dst x87-insn rep -- ) dst register? [ ESP 4 SUB @@ -192,10 +206,10 @@ M:: spill-slot float-function-param ( n dst src -- ) ! We can clobber dst here since its going to contain the ! final result dst src double-rep %copy - dst n double-rep %store-stack-param ; + dst double-rep n %store-stack-param ; M:: register float-function-param ( n dst src -- ) - src n double-rep %store-stack-param ; + src double-rep n %store-stack-param ; M:: x86.32 %unary-float-function ( dst src func -- ) 0 dst src float-function-param diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 2dc5fb4e37..4cd081d324 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -81,6 +81,14 @@ M: x86.64 %mark-deck dup load-decks-offset [+] card-mark MOV ; +M:: x86.64 %load-stack-param ( vreg rep n -- ) + rep return-reg n next-stack@ rep %copy + dst rep return-reg rep %copy ; + +M:: x86.64 %store-stack-param ( vreg rep n -- ) + rep return-reg src rep %copy + n reserved-stack-space + stack@ rep return-reg rep %copy ; + M:: x86.64 %load-reg-param ( vreg rep reg -- ) vreg reg rep %copy ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 722ad0d0f0..c5fce25df0 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -600,13 +600,9 @@ M:: x86 %local-allot ( dst size align offset -- ) : return-reg ( rep -- reg ) reg-class-of return-regs at first ; -:: %load-stack-param ( dst rep n -- ) - rep return-reg n next-stack@ rep %copy - dst rep return-reg rep %copy ; +HOOK: %load-stack-param cpu ( vreg rep n -- ) -:: %store-stack-param ( src rep n -- ) - rep return-reg src rep %copy - n reserved-stack-space + stack@ rep return-reg rep %copy ; +HOOK: %store-stack-param cpu ( vreg rep n -- ) HOOK: %load-reg-param cpu ( vreg rep reg -- ) From e7191998f84ba95683f71f5cb20da82a0f274884 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 Jul 2010 17:59:51 -0400 Subject: [PATCH 06/18] cpu.x86.64: fix typos --- basis/cpu/x86/64/64.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 4cd081d324..9fdd4551c9 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -83,10 +83,10 @@ M: x86.64 %mark-deck M:: x86.64 %load-stack-param ( vreg rep n -- ) rep return-reg n next-stack@ rep %copy - dst rep return-reg rep %copy ; + vreg rep return-reg rep %copy ; M:: x86.64 %store-stack-param ( vreg rep n -- ) - rep return-reg src rep %copy + rep return-reg vreg rep %copy n reserved-stack-space + stack@ rep return-reg rep %copy ; M:: x86.64 %load-reg-param ( vreg rep reg -- ) From 5e133189883813329b5691eaeb75069f5325cb4c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 15 Jul 2010 03:09:06 -0400 Subject: [PATCH 07/18] cpu.x86.32: fix %binary-float-function --- basis/cpu/x86/32/32.factor | 41 ++++++++++++++++---------------------- 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 379c9c697f..12a067c684 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -97,18 +97,22 @@ M: x86.32 %prepare-jump pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; M: x86.32 %load-stack-param ( dst rep n -- ) - next-stack@ swap { - { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } - { float-rep [ FLDS ?spill-slot FSTPS ] } - { double-rep [ FLDL ?spill-slot FSTPL ] } - } case ; + next-stack@ swap pick register? [ %copy ] [ + { + { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } + { float-rep [ FLDS ?spill-slot FSTPS ] } + { double-rep [ FLDL ?spill-slot FSTPL ] } + } case + ] if ; M: x86.32 %store-stack-param ( src rep n -- ) - reserved-stack-space + stack@ swap { - { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } - { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] } - { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] } - } case ; + stack@ swap pick register? [ [ swap ] dip %copy ] [ + { + { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } + { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] } + { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] } + } case + ] if ; :: load-float-return ( dst x87-insn rep -- ) dst register? [ @@ -200,25 +204,14 @@ M: x86.32 %end-callback ( -- ) 0 save-vm-ptr "end_callback" f f %c-invoke ; -GENERIC: float-function-param ( n dst src -- ) - -M:: spill-slot float-function-param ( n dst src -- ) - ! We can clobber dst here since its going to contain the - ! final result - dst src double-rep %copy - dst double-rep n %store-stack-param ; - -M:: register float-function-param ( n dst src -- ) - src double-rep n %store-stack-param ; - M:: x86.32 %unary-float-function ( dst src func -- ) - 0 dst src float-function-param + src double-rep 0 %store-stack-param 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 + src1 double-rep 0 %store-stack-param + src2 double-rep 8 %store-stack-param func "libm" load-library f %c-invoke dst double-rep %load-return ; From 48e96ef0327d1e96d5018f7bb5390c7f3e744218 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 15 Jul 2010 17:38:34 -0400 Subject: [PATCH 08/18] compiler.cfg.scheduling: update to support multiple-output instructions --- .../compiler/cfg/dependence/dependence.factor | 27 ++++---------- .../cfg/finalization/finalization.factor | 10 +++--- .../cfg/scheduling/scheduling-tests.factor | 31 +++++++++++++++- .../compiler/cfg/scheduling/scheduling.factor | 36 ++++++++++++------- 4 files changed, 66 insertions(+), 38 deletions(-) diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index bb30e4841d..d2e4a11c51 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -24,7 +24,7 @@ TUPLE: node children parent registers parent-index ; -M: node equal? [ number>> ] bi@ = ; +M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ; M: node hashcode* nip number>> ; @@ -56,12 +56,9 @@ UNION: slot-insn UNION: memory-insn ##load-memory ##load-memory-imm - ##store-memory ##store-memory-imm ; - -UNION: alien-call-insn - ##save-context - ##alien-invoke ##alien-indirect ##alien-callback - ##unary-float-function ##binary-float-function ; + ##store-memory ##store-memory-imm + alien-call-insn + slot-insn ; : chain ( node var -- ) dup get [ @@ -71,24 +68,14 @@ UNION: alien-call-insn GENERIC: add-control-edge ( node insn -- ) -M: stack-insn add-control-edge - loc>> chain ; +M: stack-insn add-control-edge loc>> chain ; -M: memory-insn add-control-edge - drop memory-insn chain ; - -M: slot-insn add-control-edge - drop slot-insn chain ; - -M: alien-call-insn add-control-edge - drop alien-call-insn chain ; +M: memory-insn add-control-edge drop memory-insn chain ; M: object add-control-edge 2drop ; : add-control-edges ( nodes -- ) - [ - [ dup insn>> add-control-edge ] each - ] with-scope ; + [ [ dup insn>> add-control-edge ] each ] with-scope ; : set-follows ( nodes -- ) [ diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 6103b4c9fa..2b731bdd90 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -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 +USING: kernel compiler.cfg.representations +compiler.cfg.scheduling compiler.cfg.gc-checks +compiler.cfg.save-contexts compiler.cfg.ssa.destruction +compiler.cfg.build-stack-frame compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.finalization : finalize-cfg ( cfg -- cfg' ) select-representations - ! schedule-instructions + schedule-instructions insert-gc-checks dup compute-uninitialized-sets insert-save-contexts diff --git a/basis/compiler/cfg/scheduling/scheduling-tests.factor b/basis/compiler/cfg/scheduling/scheduling-tests.factor index fd6179032f..be421ddebc 100644 --- a/basis/compiler/cfg/scheduling/scheduling-tests.factor +++ b/basis/compiler/cfg/scheduling/scheduling-tests.factor @@ -1,4 +1,5 @@ -USING: compiler.cfg.scheduling vocabs.loader namespaces tools.test ; +USING: compiler.cfg.scheduling compiler.cfg.instructions +vocabs.loader namespaces tools.test arrays kernel ; IN: compiler.cfg.scheduling.tests ! Recompile compiler.cfg.scheduling with extra tests, @@ -9,3 +10,31 @@ t check-scheduling? [ [ ] [ "compiler.cfg.scheduling" reload ] unit-test [ ] [ "compiler.cfg.dependence" reload ] unit-test ] with-variable + +[ + { } + { } + { T{ ##test-branch } } +] [ + V{ T{ ##test-branch } } + split-3-ways + [ >array ] tri@ +] unit-test + +[ + { T{ ##inc-d } T{ ##inc-r } T{ ##callback-inputs } } + { T{ ##add } T{ ##sub } T{ ##mul } } + { T{ ##test-branch } } +] [ + V{ + T{ ##inc-d } + T{ ##inc-r } + T{ ##callback-inputs } + T{ ##add } + T{ ##sub } + T{ ##mul } + T{ ##test-branch } + } + split-3-ways + [ >array ] tri@ +] unit-test diff --git a/basis/compiler/cfg/scheduling/scheduling.factor b/basis/compiler/cfg/scheduling/scheduling.factor index 04e4142a35..4b754e54d0 100644 --- a/basis/compiler/cfg/scheduling/scheduling.factor +++ b/basis/compiler/cfg/scheduling/scheduling.factor @@ -52,21 +52,33 @@ ERROR: bad-delete-at key assoc ; , (reorder) ] when* ; -: cut-by ( seq quot -- before after ) - dupd find drop [ cut ] [ f ] if* ; inline +UNION: initial-insn ##phi ##inc-d ##inc-r ##callback-inputs ; -UNION: initial-insn - ##phi ##inc-d ##inc-r ; +UNION: final-insn +##branch +conditional-branch-insn +##epilogue ##return +##callback-outputs ; -: split-3-ways ( insns -- first middle last ) - [ initial-insn? not ] cut-by unclip-last ; +: initial-insn-end ( insns -- n ) + [ initial-insn? not ] find drop 0 or ; + +: final-insn-start ( insns -- n ) + [ final-insn? not ] find-last drop [ 1 + ] [ 0 ] if* ; + +:: split-3-ways ( insns -- first middle last ) + insns initial-insn-end :> a + insns final-insn-start :> b + insns a head-slice + a b insns + insns b tail-slice ; : reorder ( insns -- insns' ) split-3-ways [ build-dependence-graph build-fan-in-trees [ (reorder) ] V{ } make reverse - ] dip suffix append ; + ] dip 3append ; ERROR: not-all-instructions-were-scheduled old-bb new-bb ; @@ -78,16 +90,16 @@ f check-scheduling? set-global [ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and [ old-bb new-bb not-all-instructions-were-scheduled ] unless ; -ERROR: definition-after-usage vreg old-bb new-bb ; +ERROR: definition-after-usage vregs old-bb new-bb ; :: check-usages ( new-bb old-bb -- ) HS{ } clone :> useds new-bb instructions>> split-3-ways drop nip [| insn | insn uses-vregs [ useds adjoin ] each - insn defs-vreg :> def-reg - def-reg useds in? - [ def-reg old-bb new-bb definition-after-usage ] when + insn defs-vregs :> defs-vregs + defs-vregs useds intersects? + [ defs-vregs old-bb new-bb definition-after-usage ] when ] each ; : check-scheduling ( new-bb old-bb -- ) @@ -124,7 +136,7 @@ ERROR: definition-after-usage vreg old-bb new-bb ; : might-spill? ( bb -- ? ) [ live-in assoc-size ] - [ instructions>> [ defs-vreg ] count ] bi + [ instructions>> [ defs-vregs length ] map-sum ] bi + num-registers >= ; : schedule-instructions ( cfg -- cfg' ) From 0fd636b4b9e998350b32431fcd34775a1453daa7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 15 Jul 2010 19:49:29 -0400 Subject: [PATCH 09/18] compiler.cfg: ##unbox-long-long can have multiple outputs now, clean up long long parameter passing code using this --- .../cfg/builder/alien/boxing/boxing.factor | 3 +-- .../cfg/instructions/instructions.factor | 7 +++--- basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/x86/32/32.factor | 22 ++++++++----------- vm/math.cpp | 8 +++---- vm/math.hpp | 4 ++-- 6 files changed, 21 insertions(+), 25 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 48652737be..fb57700c80 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -57,8 +57,7 @@ M: c-type unbox [ 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 + [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array int-rep long-long-on-stack? 2array dup 2array ; M: struct-c-type unbox ( src c-type -- vregs reps ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 1b7aa94fae..7efd1b3a5d 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -645,7 +645,8 @@ use: src/tagged-rep literal: unboxer rep ; FOLDABLE-INSN: ##unbox-long-long -use: src/tagged-rep out/int-rep +def: dst1/int-rep dst2/int-rep +use: src/tagged-rep literal: unboxer ; FLUSHABLE-INSN: ##local-allot @@ -875,7 +876,8 @@ UNION: hairy-clobber-insn ##call-gc alien-call-insn ##callback-inputs -##callback-outputs ; +##callback-outputs +##unbox-long-long ; ! Instructions that clobber registers but are allowed to produce ! outputs in registers. Inputs are in spill slots, except for @@ -886,7 +888,6 @@ hairy-clobber-insn ##unary-float-function ##binary-float-function ##unbox -##unbox-long-long ##box ##box-long-long ##allot-byte-array ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 277896130e..b4b5132ed5 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -585,7 +585,7 @@ HOOK: struct-return-on-stack? cpu ( -- ? ) ! can be passed to a C function, or returned from a callback HOOK: %unbox cpu ( dst src func rep -- ) -HOOK: %unbox-long-long cpu ( src out func -- ) +HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- ) HOOK: %local-allot cpu ( dst size align offset -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 12a067c684..ee6082425b 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -158,27 +158,23 @@ M:: x86.32 %unbox ( dst src func rep -- ) src func call-unbox-func dst rep %load-return ; -M:: x86.32 %unbox-long-long ( src out func -- ) - EAX src int-rep %copy - 0 stack@ EAX MOV - EAX out int-rep %copy - 4 stack@ EAX MOV - 8 save-vm-ptr - func f f %c-invoke ; +M:: x86.32 %unbox-long-long ( dst1 dst2 src func -- ) + src int-rep 0 %store-stack-param + 4 save-vm-ptr + func f f %c-invoke + dst1 EAX int-rep %copy + dst2 EDX int-rep %copy ; M:: x86.32 %box ( dst src func rep gc-map -- ) + src rep 0 %store-stack-param rep rep-size save-vm-ptr - src rep %store-return - 0 stack@ rep %load-return func f gc-map %c-invoke dst EAX tagged-rep %copy ; M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) + src1 int-rep 0 %store-stack-param + src2 int-rep 4 %store-stack-param 8 save-vm-ptr - EAX src1 int-rep %copy - 0 stack@ EAX int-rep %copy - EAX src2 int-rep %copy - 4 stack@ EAX int-rep %copy func f gc-map %c-invoke dst EAX tagged-rep %copy ; diff --git a/vm/math.cpp b/vm/math.cpp index 737b35ab85..e64db2690e 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -491,9 +491,9 @@ s64 factor_vm::to_signed_8(cell obj) } } -VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent) +VM_C_API s64 to_signed_8(cell obj, factor_vm *parent) { - *out = parent->to_signed_8(obj); + return parent->to_signed_8(obj); } cell factor_vm::from_unsigned_8(u64 n) @@ -524,9 +524,9 @@ u64 factor_vm::to_unsigned_8(cell obj) } } -VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent) +VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent) { - *out = parent->to_unsigned_8(obj); + return parent->to_unsigned_8(obj); } VM_C_API cell from_float(float flo, factor_vm *parent) diff --git a/vm/math.hpp b/vm/math.hpp index 13934048cd..dc6d37bcfd 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -90,8 +90,8 @@ VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm); VM_C_API cell from_signed_8(s64 n, factor_vm *vm); VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm); -VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent); -VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent); +VM_C_API s64 to_signed_8(cell obj, factor_vm *parent); +VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent); VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm); VM_C_API cell to_cell(cell tagged, factor_vm *vm); From 60ddbd9d9b86be4be58c68e54fdaa285e4585da2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 15 Jul 2010 20:55:31 -0400 Subject: [PATCH 10/18] compiler.cfg.scheduling: ##dispatch must go at the end since its a control flow transfer --- .../cfg/scheduling/scheduling-tests.factor | 15 +++++++++++++++ basis/compiler/cfg/scheduling/scheduling.factor | 1 + 2 files changed, 16 insertions(+) diff --git a/basis/compiler/cfg/scheduling/scheduling-tests.factor b/basis/compiler/cfg/scheduling/scheduling-tests.factor index be421ddebc..b50305c814 100644 --- a/basis/compiler/cfg/scheduling/scheduling-tests.factor +++ b/basis/compiler/cfg/scheduling/scheduling-tests.factor @@ -38,3 +38,18 @@ t check-scheduling? [ split-3-ways [ >array ] tri@ ] unit-test + +[ + { } + { T{ ##add } T{ ##sub } T{ ##mul } } + { T{ ##dispatch } } +] [ + V{ + T{ ##add } + T{ ##sub } + T{ ##mul } + T{ ##dispatch } + } + split-3-ways + [ >array ] tri@ +] unit-test diff --git a/basis/compiler/cfg/scheduling/scheduling.factor b/basis/compiler/cfg/scheduling/scheduling.factor index 4b754e54d0..d56b5559ce 100644 --- a/basis/compiler/cfg/scheduling/scheduling.factor +++ b/basis/compiler/cfg/scheduling/scheduling.factor @@ -56,6 +56,7 @@ UNION: initial-insn ##phi ##inc-d ##inc-r ##callback-inputs ; UNION: final-insn ##branch +##dispatch conditional-branch-insn ##epilogue ##return ##callback-outputs ; From 5b31cbcb3c9b933eb94c1f61a4420e0f556aa33e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Jul 2010 17:13:38 -0400 Subject: [PATCH 11/18] alien.data: document with-scoped-allocation and with-out-parameters, and add initial: syntax --- basis/alien/data/data-docs.factor | 45 ++++++++++++++++++++++++++++++- basis/alien/data/data.factor | 28 ++++++++++++++++--- basis/compiler/tests/alien.factor | 16 +++++++++-- 3 files changed, 83 insertions(+), 6 deletions(-) diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 1401190f45..930232b86c 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences io.encodings.string debugger destructors -vocabs.loader classes.struct ; +vocabs.loader classes.struct quotations ; IN: alien.data HELP: @@ -44,6 +44,49 @@ HELP: malloc-byte-array { string>alien alien>string malloc-string } related-words +HELP: with-scoped-allocation +{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } } +{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns." +$nl +"A scoped allocation specifier is either:" +{ $list + "a C type name," + { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." } +} +"If no initial value is specified, the contents of the allocated memory are undefined." } +{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } +{ $examples + { $example + "USING: accessors alien.c-types alien.data +classes.struct kernel math math.functions +prettyprint ; +IN: scratchpad + +STRUCT: point { x int } { y int } ; + +: scoped-allocation-test ( -- x ) + { point } [ + 3 >>x 4 >>y + [ x>> sq ] [ y>> sq ] bi + sqrt + ] with-scoped-allocation ; + +scoped-allocation-test ." +"5.0" + } +} ; + +HELP: with-out-parameters +{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "finish" quotation } { "values..." "zero or more values" } } +{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns." +$nl +"A scoped allocation specifier is either:" +{ $list + "a C type name," + { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." } +} +"If no initial value is specified, the contents of the allocated memory are undefined." } +{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ; + ARTICLE: "malloc" "Manual memory management" "Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case." $nl diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 2f5e4b72c6..ab5824bfd2 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -2,7 +2,8 @@ USING: accessors alien alien.c-types alien.arrays alien.strings arrays byte-arrays cpu.architecture fry io io.encodings.binary io.files io.streams.memory kernel libc math math.functions -sequences words macros combinators generalizations ; +sequences words macros combinators generalizations +stack-checker.dependencies combinators.short-circuit ; QUALIFIED: math IN: alien.data @@ -88,13 +89,34 @@ ERROR: local-allocation-error ; ! to still be abl to access scope-allocated data. ; +MACRO: (simple-local-allot) ( c-type -- quot ) + [ depends-on-c-type ] + [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ; + +: [hairy-local-allot] ( c-type initial -- quot ) + over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ; + +: hairy-local-allot? ( obj -- ? ) + { + [ array? ] + [ length 3 = ] + [ second initial: eq? ] + } 1&& ; + +MACRO: (hairy-local-allot) ( obj -- quot ) + dup hairy-local-allot? + [ first3 nip [hairy-local-allot] ] + [ '[ _ (simple-local-allot) ] ] + if ; + MACRO: (local-allots) ( c-types -- quot ) - [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ; + [ '[ _ (hairy-local-allot) ] ] map [ ] join ; MACRO: box-values ( c-types -- quot ) [ c-type-boxer-quot ] map '[ _ spread ] ; MACRO: out-parameters ( c-types -- quot ) + [ dup hairy-local-allot? [ first ] when ] map [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi '[ _ nkeep _ spread ] ; @@ -104,7 +126,7 @@ PRIVATE> [ [ (local-allots) ] [ box-values ] bi ] dip call (cleanup-allot) ; inline -: with-out-parameters ( c-types quot finish -- values ) +: with-out-parameters ( c-types quot finish -- values... ) [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call (cleanup-allot) ; inline diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 476e6da39e..47d9b4b337 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -776,10 +776,22 @@ mingw? [ [ 3 ] [ blah ] unit-test -: out-param-test ( -- b ) +: out-param-test-1 ( -- b ) { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ; -[ 12 ] [ out-param-test ] unit-test +[ 12 ] [ out-param-test-1 ] unit-test + +: out-param-test-2 ( -- b ) + { { int initial: 12 } } [ drop ] [ ] with-out-parameters ; + +[ 12 ] [ out-param-test-2 ] unit-test + +: out-param-test-3 ( -- x y ) + { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ] + [ clone ] with-out-parameters + [ x>> ] [ y>> ] bi ; + +[ 3.0 4.0 ] [ out-param-test-3 ] unit-test : out-param-callback ( -- a ) void { int pointer: int } cdecl From 5803419b9d217ad48f0ff892eee8b13ecd8079ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Jul 2010 17:13:44 -0400 Subject: [PATCH 12/18] libc: add memset just because --- basis/libc/libc.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 68d041ac8f..f54a03ae2f 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -91,6 +91,8 @@ PRIVATE> : free ( alien -- ) >c-ptr [ delete-malloc ] [ (free) ] bi ; +FUNCTION: void memset ( void* buf, int char, size_t size ) ; + FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ; FUNCTION: int memcmp ( void* a, void* b, ulong size ) ; From 446ee6896db8452b8d0d2eb462c935d4c8af7296 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Jul 2010 17:32:05 -0400 Subject: [PATCH 13/18] alien.data: remove second quotation parameter from with-out-parameters, now all values are copied properly and calling 'clone' on structs in this quotation is not necessary --- basis/alien/arrays/arrays.factor | 3 ++ basis/alien/c-types/c-types.factor | 8 +++++ basis/alien/data/data-docs.factor | 2 +- basis/alien/data/data.factor | 12 ++++---- basis/checksums/openssl/openssl.factor | 5 ++-- basis/cocoa/messages/messages.factor | 2 +- basis/cocoa/nibs/nibs.factor | 2 +- basis/cocoa/plists/plists.factor | 2 +- basis/compiler/tests/alien.factor | 8 ++--- basis/compiler/tests/optimizer.factor | 1 - basis/core-foundation/strings/strings.factor | 3 +- basis/core-text/core-text.factor | 2 +- basis/db/postgresql/lib/lib.factor | 2 +- basis/db/sqlite/lib/lib.factor | 6 ++-- basis/game/input/x11/x11.factor | 2 +- basis/io/backend/windows/nt/nt.factor | 2 +- .../windows/nt/privileges/privileges.factor | 2 +- basis/io/files/info/windows/windows.factor | 29 +++++++++---------- basis/io/launcher/unix/unix.factor | 2 +- basis/io/launcher/windows/windows.factor | 2 +- basis/io/sockets/windows/nt/nt.factor | 2 +- basis/iokit/iokit.factor | 4 +-- basis/math/vectors/simd/simd-tests.factor | 4 +-- basis/opengl/framebuffers/framebuffers.factor | 2 +- basis/opengl/opengl.factor | 2 +- basis/opengl/shaders/shaders.factor | 4 +-- basis/opengl/textures/textures.factor | 4 +-- basis/pango/cairo/cairo.factor | 4 +-- basis/random/windows/windows.factor | 2 +- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/ui/backend/windows/windows.factor | 4 +-- basis/ui/backend/x11/x11.factor | 6 ++-- basis/windows/dwmapi/dwmapi.factor | 2 +- basis/windows/offscreen/offscreen.factor | 2 +- basis/windows/uniscribe/uniscribe.factor | 4 +-- 35 files changed, 76 insertions(+), 69 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 42e40483f6..c020feaa76 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -56,6 +56,9 @@ M: string-type c-type-unboxer-quot M: string-type c-type-getter drop [ alien-cell ] ; +M: string-type c-type-copier + drop [ ] ; + M: string-type c-type-setter drop [ set-alien-cell ] ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 412bf9259a..389883535f 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -89,6 +89,10 @@ GENERIC: c-type-getter ( name -- quot ) M: c-type c-type-getter getter>> ; +GENERIC: c-type-copier ( name -- quot ) + +M: c-type c-type-copier drop [ ] ; + GENERIC: c-type-setter ( name -- quot ) M: c-type c-type-setter setter>> ; @@ -118,6 +122,9 @@ MIXIN: value-type MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) ) [ c-type-getter ] [ c-type-boxer-quot ] bi append ; +MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) ) + [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ; + MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) ) [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ] [ c-type-setter ] @@ -139,6 +146,7 @@ PROTOCOL: c-type-protocol c-type-unboxer-quot c-type-rep c-type-getter + c-type-copier c-type-setter c-type-align c-type-align-first diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 930232b86c..02a31976c7 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -76,7 +76,7 @@ scoped-allocation-test ." } ; HELP: with-out-parameters -{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "finish" quotation } { "values..." "zero or more values" } } +{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } } { $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns." $nl "A scoped allocation specifier is either:" diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index ab5824bfd2..d755ac387b 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -70,7 +70,10 @@ M: value-type c-type-rep drop int-rep ; M: value-type c-type-getter drop [ swap ] ; -M: value-type c-type-setter ( type -- quot ) +M: value-type c-type-copier + heap-size '[ _ memory>byte-array ] ; + +M: value-type c-type-setter [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ; M: array c-type-boxer-quot @@ -117,7 +120,7 @@ MACRO: box-values ( c-types -- quot ) MACRO: out-parameters ( c-types -- quot ) [ dup hairy-local-allot? [ first ] when ] map - [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi + [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi '[ _ nkeep _ spread ] ; PRIVATE> @@ -126,8 +129,8 @@ PRIVATE> [ [ (local-allots) ] [ box-values ] bi ] dip call (cleanup-allot) ; inline -: with-out-parameters ( c-types quot finish -- values... ) - [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call +: with-out-parameters ( c-types quot -- values... ) + [ drop (local-allots) ] [ swap out-parameters ] 2bi (cleanup-allot) ; inline GENERIC: binary-zero? ( value -- ? ) @@ -137,4 +140,3 @@ M: f binary-zero? drop t ; inline M: integer binary-zero? zero? ; inline M: math:float binary-zero? double>bits zero? ; inline M: complex binary-zero? >rect [ binary-zero? ] both? ; inline - diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index 1fec109d5f..41c8537d45 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -48,9 +48,8 @@ M: evp-md-context dispose* : digest-value ( ctx -- value ) handle>> { { int EVP_MAX_MD_SIZE } int } - [ EVP_DigestFinal_ex ssl-error ] - [ memory>byte-array ] - with-out-parameters ; + [ EVP_DigestFinal_ex ssl-error ] with-out-parameters + memory>byte-array ; PRIVATE> diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 029b3f46e6..4d786aaf72 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -216,7 +216,7 @@ ERROR: no-objc-type name ; objc-methods get set-at ; : each-method-in-class ( class quot -- ) - [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip + [ { uint } [ class_copyMethodList ] with-out-parameters ] dip over 0 = [ 3drop ] [ [ ] dip [ each ] [ drop (free) ] 2bi diff --git a/basis/cocoa/nibs/nibs.factor b/basis/cocoa/nibs/nibs.factor index d4a11cc9d5..320b4783a5 100644 --- a/basis/cocoa/nibs/nibs.factor +++ b/basis/cocoa/nibs/nibs.factor @@ -16,6 +16,6 @@ IN: cocoa.nibs : nib-objects ( anNSNib -- objects/f ) f - { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ] + { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] with-out-parameters swap [ CF>array ] [ drop f ] if ; \ No newline at end of file diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 80d58e6340..e8d28b0004 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -38,7 +38,7 @@ DEFER: plist> : (read-plist) ( NSData -- id ) NSPropertyListSerialization swap kCFPropertyListImmutable f { void* } - [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ] + [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] with-out-parameters [ -> release "read-plist failed" throw ] when* ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 47d9b4b337..f263e1e0f8 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -777,18 +777,18 @@ mingw? [ [ 3 ] [ blah ] unit-test : out-param-test-1 ( -- b ) - { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ; + { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ; [ 12 ] [ out-param-test-1 ] unit-test : out-param-test-2 ( -- b ) - { { int initial: 12 } } [ drop ] [ ] with-out-parameters ; + { { int initial: 12 } } [ drop ] with-out-parameters ; [ 12 ] [ out-param-test-2 ] unit-test : out-param-test-3 ( -- x y ) { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ] - [ clone ] with-out-parameters + with-out-parameters [ x>> ] [ y>> ] bi ; [ 3.0 4.0 ] [ out-param-test-3 ] unit-test @@ -801,6 +801,6 @@ mingw? [ { int } [ swap void { int pointer: int } cdecl alien-indirect - ] [ ] with-out-parameters ; + ] with-out-parameters ; [ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 0d08c592a9..23b615f1ae 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -454,7 +454,6 @@ STRUCT: BitmapData { Scan0 void* } ; [ { BitmapData } [ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ] - [ clone ] with-out-parameters Scan0>> ] compile-call ] unit-test diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index b78e1046fe..24bb38e09c 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -78,8 +78,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString ( [ 0 swap kCFStringEncodingUTF8 0 f ] keep 4 * 1 + [ dup length - { CFIndex } [ CFStringGetBytes drop ] [ ] - with-out-parameters + { CFIndex } [ CFStringGetBytes drop ] with-out-parameters ] keep swap head-slice utf8 decode ; diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 4de8b2c06a..014956aba2 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -51,7 +51,7 @@ TUPLE: line < disposable line metrics image loc dim ; : typographic-bounds ( line -- width ascent descent leading ) { CGFloat CGFloat CGFloat } - [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline + [ CTLineGetTypographicBounds ] with-out-parameters ; inline : store-typographic-bounds ( metrics width ascent descent leading -- metrics ) { diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 7fe40a73d6..11218d21ff 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -146,7 +146,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) ] [ &postgresql-free ] if - ] [ ] with-out-parameters memory>byte-array + ] with-out-parameters memory>byte-array ] with-destructors ] [ drop pq-get-is-null nip [ f ] [ B{ } clone ] if diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 58033a281e..0935fb6c91 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -27,7 +27,7 @@ ERROR: sqlite-sql-error < sql-error n string ; : sqlite-open ( path -- db ) normalize-path - { void* } [ sqlite3_open sqlite-check-result ] [ ] + { void* } [ sqlite3_open sqlite-check-result ] with-out-parameters ; : sqlite-close ( db -- ) @@ -36,8 +36,8 @@ ERROR: sqlite-sql-error < sql-error n string ; : sqlite-prepare ( db sql -- handle ) utf8 encode dup length { void* void* } - [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ] - with-out-parameters ; + [ sqlite3_prepare_v2 sqlite-check-result ] + with-out-parameters drop ; : sqlite-bind-parameter-index ( handle name -- index ) sqlite3_bind_parameter_index ; diff --git a/basis/game/input/x11/x11.factor b/basis/game/input/x11/x11.factor index ecdbee8284..cc3e4cd531 100644 --- a/basis/game/input/x11/x11.factor +++ b/basis/game/input/x11/x11.factor @@ -89,7 +89,7 @@ M: x11-game-input-backend read-keyboard : query-pointer ( -- x y buttons ) dpy get dup XDefaultRootWindow { int int int int int int int } - [ XQueryPointer drop ] [ ] with-out-parameters + [ XQueryPointer drop ] with-out-parameters [ 4 ndrop ] 3dip ; SYMBOL: mouse-reset? diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index c0a6ee807d..69a86c7ec3 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -56,7 +56,7 @@ M: winnt add-completion ( win32-handle -- ) nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout master-completion-port get-global { int void* pointer: OVERLAPPED } - [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters + [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters :> ( error? bytes key overlapped ) bytes overlapped error? ; diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 27687df9d5..896785b048 100644 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -15,7 +15,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES : (open-process-token) ( handle -- handle ) flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } { PHANDLE } - [ OpenProcessToken win32-error=0/f ] [ ] + [ OpenProcessToken win32-error=0/f ] with-out-parameters ; : open-process-token ( -- handle ) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 96e302860d..2971a15b4b 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -21,7 +21,7 @@ IN: io.files.info.windows TUPLE: windows-file-info < file-info attributes ; : get-compressed-file-size ( path -- n ) - { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters + { DWORD } [ GetCompressedFileSize ] with-out-parameters over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ; : set-windows-size-on-disk ( file-info path -- file-info ) @@ -100,12 +100,12 @@ CONSTANT: path-length $[ MAX_PATH 1 + ] : volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) { { ushort path-length } DWORD DWORD DWORD { ushort path-length } } [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ] - [ [ utf16n alien>string ] 4dip utf16n alien>string ] - with-out-parameters ; + with-out-parameters + [ utf16n alien>string ] 4dip utf16n alien>string ; : file-system-space ( normalized-path -- available-space total-space free-space ) { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER } - [ GetDiskFreeSpaceEx win32-error=0/f ] [ ] + [ GetDiskFreeSpaceEx win32-error=0/f ] with-out-parameters ; : calculate-file-system-info ( file-system-info -- file-system-info' ) @@ -149,24 +149,21 @@ CONSTANT: names-buf-length 16384 : volume>paths ( string -- array ) { { ushort names-buf-length } uint } [ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ] - [ head utf16n alien>string { CHAR: \0 } split ] - with-out-parameters ; + with-out-parameters + head utf16n alien>string { CHAR: \0 } split ; : find-first-volume ( -- string handle ) { { ushort path-length } } [ path-length FindFirstVolume dup win32-error=0/f ] - [ utf16n alien>string ] - with-out-parameters swap ; + with-out-parameters utf16n alien>string swap ; : find-next-volume ( handle -- string/f ) { { ushort path-length } } - [ path-length FindNextVolume ] - [ - swap 0 = [ - GetLastError ERROR_NO_MORE_FILES = - [ drop f ] [ win32-error-string throw ] if - ] [ utf16n alien>string ] if - ] with-out-parameters ; + [ path-length FindNextVolume ] with-out-parameters + swap 0 = [ + GetLastError ERROR_NO_MORE_FILES = + [ drop f ] [ win32-error-string throw ] if + ] [ utf16n alien>string ] if ; : find-volumes ( -- array ) find-first-volume @@ -189,8 +186,8 @@ M: winnt file-systems ( -- array ) normalize-path open-read &dispose handle>> { FILETIME FILETIME FILETIME } [ GetFileTime win32-error=0/f ] - [ [ FILETIME>timestamp >local-time ] tri@ ] with-out-parameters + [ FILETIME>timestamp >local-time ] tri@ ] with-destructors ; : set-file-times ( path timestamp/f timestamp/f timestamp/f -- ) diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index e036f34cc6..1eed2eb75e 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -95,7 +95,7 @@ TUPLE: signal n ; dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ; M: unix wait-for-processes ( -- ? ) - { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters + { int } [ -1 swap WNOHANG waitpid ] with-out-parameters swap dup 0 <= [ 2drop t ] [ diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index cc9e52a189..ecf730716a 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -159,7 +159,7 @@ M: windows kill-process* ( handle -- ) : exit-code ( process -- n ) hProcess>> - { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters + { DWORD } [ GetExitCodeProcess ] with-out-parameters swap win32-error=0/f ; : process-exited ( process -- ) diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor index 17e92b9b9f..13f399697e 100644 --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -26,7 +26,7 @@ M: winnt WSASocket-flags ( -- DWORD ) WSAIoctl SOCKET_ERROR = [ winsock-error-string throw ] when - ] [ ] with-out-parameters ; + ] with-out-parameters ; TUPLE: ConnectEx-args port s name namelen lpSendBuffer dwSendDataLength diff --git a/basis/iokit/iokit.factor b/basis/iokit/iokit.factor index 5720fc5997..4dc4932222 100644 --- a/basis/iokit/iokit.factor +++ b/basis/iokit/iokit.factor @@ -131,11 +131,11 @@ TUPLE: mach-error error-code error-string ; dup KERN_SUCCESS = [ drop ] [ throw ] if ; : master-port ( -- port ) - MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ; + MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] with-out-parameters ; : io-services-matching-dictionary ( nsdictionary -- iterator ) master-port swap - { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ; + { uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ; : io-services-matching-service ( service -- iterator ) IOServiceMatching io-services-matching-dictionary ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 9bc90cbf7e..3b8ae7d2b4 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -684,7 +684,7 @@ USE: alien { c:int float-4 } [ [ 123 swap 0 c:int c:set-alien-value ] [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi* - ] [ ] with-out-parameters ; + ] with-out-parameters ; [ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test @@ -696,7 +696,7 @@ USE: alien { c:int } [ 123 swap 0 c:int c:set-alien-value >float (simd-stack-spill-test) float-4-with swap cos v*n - ] [ ] with-out-parameters ; + ] with-out-parameters ; [ ] [ 1.047197551196598 simd-stack-spill-test diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor index ce19a2ec89..5d28d1852c 100644 --- a/basis/opengl/framebuffers/framebuffers.factor +++ b/basis/opengl/framebuffers/framebuffers.factor @@ -51,4 +51,4 @@ IN: opengl.framebuffers : framebuffer-attachment ( attachment -- id ) GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME - { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ; + { uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 893a8dfbd6..fda840b281 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -139,7 +139,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) swap glPushAttrib call glPopAttrib ; inline : (gen-gl-object) ( quot -- id ) - [ 1 { uint } ] dip [ ] with-out-parameters ; inline + [ 1 { uint } ] dip with-out-parameters ; inline : (delete-gl-object) ( id quot -- ) [ 1 swap ] dip call ; inline diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index 4e17a01624..720665a1b8 100644 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -20,7 +20,7 @@ IN: opengl.shaders dup integer? [ glIsShader c-bool> ] [ drop f ] if ; : gl-shader-get-int ( shader enum -- value ) - { int } [ glGetShaderiv ] [ ] with-out-parameters ; + { int } [ glGetShaderiv ] with-out-parameters ; : gl-shader-ok? ( shader -- ? ) GL_COMPILE_STATUS gl-shader-get-int c-bool> ; @@ -79,7 +79,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; : gl-program-get-int ( program enum -- value ) - { int } [ glGetProgramiv ] [ ] with-out-parameters ; + { int } [ glGetProgramiv ] with-out-parameters ; : gl-program-ok? ( program -- ? ) GL_LINK_STATUS gl-program-get-int c-bool> ; diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index dacea0888a..f33ea9e47d 100644 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -406,7 +406,7 @@ PRIVATE> [ [ max-texture-size tesselate ] dip ] if ; : get-texture-float ( target level enum -- value ) - { float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline + { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline : get-texture-int ( target level enum -- value ) - { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline + { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor index 68a9f2f6df..891a353281 100644 --- a/basis/pango/cairo/cairo.factor +++ b/basis/pango/cairo/cairo.factor @@ -137,7 +137,7 @@ SYMBOL: dpi : line-offset>x ( layout n -- x ) #! n is an index into the UTF8 encoding of the text [ drop first-line ] [ swap string>> >utf8-index ] 2bi - 0 { int } [ pango_layout_line_index_to_x ] [ ] with-out-parameters + 0 { int } [ pango_layout_line_index_to_x ] with-out-parameters pango>float ; : x>line-offset ( layout x -- n ) @@ -146,7 +146,7 @@ SYMBOL: dpi [ first-line ] dip float>pango { int int } - [ pango_layout_line_x_to_index drop ] [ ] with-out-parameters + [ pango_layout_line_x_to_index drop ] with-out-parameters swap ] [ drop string>> ] 2bi utf8-index> + ; diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 0629481a1b..5c7026bcc8 100755 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -23,7 +23,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer" type flags CryptAcquireContextW - ] [ ] with-out-parameters ; + ] with-out-parameters ; : acquire-crypto-context ( provider type -- handle ) CRYPT_MACHINE_KEYSET diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 13f07b9d41..48647df92d 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -57,7 +57,7 @@ M: cocoa-ui-backend (pixel-format-attribute) [ drop f ] [ first - { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ] + { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] with-out-parameters ] if-empty ; diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 06ea870196..dba6184c58 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -60,14 +60,14 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{ : arb-make-pixel-format ( world attributes -- pf ) [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int } - [ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ; + [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ; : arb-pixel-format-attribute ( pixel-format attribute -- value ) >WGL_ARB [ drop f ] [ [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip first { int } - [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ] + [ wglGetPixelFormatAttribivARB win32-error=0/f ] with-out-parameters ] if-empty ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index f3d603ddd8..e2ba7ab4e5 100644 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -39,11 +39,11 @@ SINGLETON: x11-ui-backend XGetWindowProperty Success assert= ] + with-out-parameters [| type format n-atoms bytes-after atoms | atoms n-atoms >array atoms XFree - ] - with-out-parameters ; + ] call ; : net-wm-hint-supported? ( atom -- ? ) supported-net-wm-hints member? ; @@ -93,7 +93,7 @@ M: x11-ui-backend (pixel-format-attribute) [ handle>> ] [ >glx-visual ] bi* [ 2drop f ] [ first - { int } [ glXGetConfig drop ] [ ] with-out-parameters + { int } [ glXGetConfig drop ] with-out-parameters ] if-empty ; CONSTANT: modifiers diff --git a/basis/windows/dwmapi/dwmapi.factor b/basis/windows/dwmapi/dwmapi.factor index b9830a5347..0da98eaf14 100755 --- a/basis/windows/dwmapi/dwmapi.factor +++ b/basis/windows/dwmapi/dwmapi.factor @@ -34,5 +34,5 @@ CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E : composition-enabled? ( -- ? ) windows-major 6 >= - [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ] + [ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ] [ f ] if ; diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor index c2587698d0..02b72388a7 100644 --- a/basis/windows/offscreen/offscreen.factor +++ b/basis/windows/offscreen/offscreen.factor @@ -27,7 +27,7 @@ IN: windows.offscreen [ nip ] [ swap (bitmap-info) DIB_RGB_COLORS { void* } - [ f 0 CreateDIBSection ] [ ] with-out-parameters + [ f 0 CreateDIBSection ] with-out-parameters ] 2bi [ [ SelectObject drop ] keep ] dip ; diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 92fec0a677..cde6c11efb 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -20,12 +20,12 @@ TUPLE: script-string < disposable font string metrics ssa size image ; swap ! icp FALSE ! fTrailing ] if - { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ; + { int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ; : x>line-offset ( x script-string -- n trailing ) ssa>> ! ssa swap ! iX - { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ; + { int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ; Date: Fri, 16 Jul 2010 19:57:45 -0400 Subject: [PATCH 14/18] compiler.cfg: nuke ##allot-byte-array instruction --- .../cfg/builder/alien/boxing/boxing.factor | 5 +-- basis/compiler/cfg/gc-checks/gc-checks.factor | 1 + .../cfg/instructions/instructions.factor | 8 +---- .../cfg/intrinsics/allot/allot.factor | 4 +-- .../cfg/linear-scan/linear-scan-tests.factor | 31 +++++++++++++++++++ basis/compiler/codegen/codegen.factor | 1 - basis/cpu/architecture/architecture.factor | 2 -- basis/cpu/x86/32/32.factor | 6 ---- basis/cpu/x86/64/64.factor | 6 ---- vm/byte_arrays.cpp | 5 --- vm/byte_arrays.hpp | 2 -- 11 files changed, 38 insertions(+), 33 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index fb57700c80..0234c12808 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -4,7 +4,8 @@ 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.registers compiler.cfg.instructions cpu.architecture ; +compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.intrinsics.allot cpu.architecture ; IN: compiler.cfg.builder.alien.boxing SYMBOL: struct-return-area @@ -117,7 +118,7 @@ M: long-long-type box ^^box-long-long ; M: struct-c-type box - '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip + '[ _ heap-size emit-allot-byte-array dup ^^unbox-byte-array ] 2dip implode-struct ; GENERIC: box-parameter ( vregs reps c-type -- dst ) diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index eab3fce666..8213c577e1 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -31,6 +31,7 @@ GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? [ call-index , ] when insn-index 1 + f ; +M: ##callback-inputs gc-check-offsets* gc-check-here ; M: ##phi gc-check-offsets* gc-check-here ; M: gc-map-insn gc-check-offsets* gc-check-here ; M: ##allocation gc-check-offsets* 3drop t ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 7efd1b3a5d..f78b77d2f0 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -663,10 +663,6 @@ def: dst/tagged-rep use: src1/int-rep src2/int-rep literal: boxer gc-map ; -FLUSHABLE-INSN: ##allot-byte-array -def: dst/tagged-rep -literal: size gc-map ; - ! Alien call inputs and outputs are arrays of triples with shape ! { vreg rep stack#/reg } @@ -855,7 +851,6 @@ UNION: gc-map-insn ##call-gc ##box ##box-long-long -##allot-byte-array factor-call-insn ; M: gc-map-insn clone call-next-method [ clone ] change-gc-map ; @@ -889,8 +884,7 @@ hairy-clobber-insn ##binary-float-function ##unbox ##box -##box-long-long -##allot-byte-array ; +##box-long-long ; ! Instructions that have complex expansions and require that the ! output registers are not equal to any of the input registers diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index ff4c28a488..1b7e183b79 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -66,13 +66,12 @@ IN: compiler.cfg.intrinsics.allot 16 + byte-array ^^allot ; : emit-allot-byte-array ( len -- dst ) - ds-drop dup ^^allot-byte-array [ byte-array store-length ] [ ds-push ] [ ] tri ; : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-(byte-array)? - [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; + [ nip ds-drop emit-allot-byte-array drop ] [ drop emit-primitive ] if ; :: zero-byte-array ( len reg -- ) 0 ^^load-literal :> elt @@ -84,6 +83,7 @@ IN: compiler.cfg.intrinsics.allot :: emit- ( node -- ) node node-input-infos first literal>> dup expand-? [ :> len + ds-drop len emit-allot-byte-array :> reg len reg zero-byte-array ] [ drop node emit-primitive ] if ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 873ba6ee5c..c5534a3040 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -11,6 +11,7 @@ compiler.cfg.rpo compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.comparisons +compiler.cfg.ssa.destruction compiler.cfg.linear-scan compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals @@ -25,6 +26,36 @@ IN: compiler.cfg.linear-scan.tests check-allocation? on check-numbering? on +! Live interval calculation + +! A value is defined and never used; make sure it has the right +! live range +V{ + T{ ##load-integer f 1 0 } + T{ ##replace-imm f D 0 "hi" } + T{ ##branch } +} 0 test-bb + +: test-live-intervals ( -- ) + cfg new 0 get >>entry + [ cfg set ] [ number-instructions ] [ compute-live-intervals ] tri + 2drop ; + +[ ] [ + H{ + { 1 int-rep } + } representations set + H{ + { 1 1 } + } leader-map set + test-live-intervals +] unit-test + +[ 0 0 ] [ + 1 live-intervals get at [ start>> ] [ end>> ] bi +] unit-test + +! Live range and interval splitting [ { T{ live-range f 1 10 } T{ live-range f 15 15 } } { T{ live-range f 16 20 } } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 654d676ad1..e3746090cd 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -288,7 +288,6 @@ CODEGEN: ##unbox-long-long %unbox-long-long CODEGEN: ##local-allot %local-allot CODEGEN: ##box %box CODEGEN: ##box-long-long %box-long-long -CODEGEN: ##allot-byte-array %allot-byte-array CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##alien-indirect %alien-indirect CODEGEN: ##alien-assembly %alien-assembly diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b4b5132ed5..e69a1cd283 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -596,8 +596,6 @@ HOOK: %box cpu ( dst src func rep gc-map -- ) HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- ) -HOOK: %allot-byte-array cpu ( dst size gc-map -- ) - HOOK: %save-context cpu ( temp1 temp2 -- ) HOOK: %c-invoke cpu ( symbols dll gc-map -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index ee6082425b..7ed80d1e39 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -178,12 +178,6 @@ M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) 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 %c-invoke - dst EAX tagged-rep %copy ; - M: x86.32 %c-invoke [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 9fdd4551c9..0aad0382fd 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -107,12 +107,6 @@ M:: x86.64 %box ( dst src func rep gc-map -- ) 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 %c-invoke - dst int-rep %load-return ; - M: x86.64 %c-invoke [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip gc-map-here ; diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index fb1b44c91e..467e41029d 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -10,11 +10,6 @@ byte_array *factor_vm::allot_byte_array(cell size) return array; } -VM_C_API cell allot_byte_array(cell size, factor_vm *parent) -{ - return tag(parent->allot_byte_array(size)); -} - void factor_vm::primitive_byte_array() { cell size = unbox_array_size(); diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index f0faac248c..8b686d4e57 100755 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -21,6 +21,4 @@ template byte_array *factor_vm::byte_array_from_value(Type *value return data; } -VM_C_API cell allot_byte_array(cell size, factor_vm *parent); - } From e3edb2653d886c55275712f47855de986dc11b7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Jul 2010 20:04:03 -0400 Subject: [PATCH 15/18] compiler.cfg.intrinsics.allot: clean up --- basis/compiler/cfg/builder/alien/boxing/boxing.factor | 2 +- basis/compiler/cfg/intrinsics/allot/allot.factor | 10 ++++------ 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 0234c12808..abfad6a451 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -118,7 +118,7 @@ M: long-long-type box ^^box-long-long ; M: struct-c-type box - '[ _ heap-size emit-allot-byte-array dup ^^unbox-byte-array ] 2dip + '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip implode-struct ; GENERIC: box-parameter ( vregs reps c-type -- dst ) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 1b7e183b79..72816bde7f 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -62,16 +62,15 @@ IN: compiler.cfg.intrinsics.allot : bytes>cells ( m -- n ) cell align cell /i ; -: ^^allot-byte-array ( n -- dst ) - 16 + byte-array ^^allot ; +: ^^allot-byte-array ( len -- dst ) + dup 16 + byte-array ^^allot [ byte-array store-length ] keep ; : emit-allot-byte-array ( len -- dst ) - dup ^^allot-byte-array - [ byte-array store-length ] [ ds-push ] [ ] tri ; + ds-drop ^^allot-byte-array dup ds-push ; : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-(byte-array)? - [ nip ds-drop emit-allot-byte-array drop ] [ drop emit-primitive ] if ; + [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; :: zero-byte-array ( len reg -- ) 0 ^^load-literal :> elt @@ -83,7 +82,6 @@ IN: compiler.cfg.intrinsics.allot :: emit- ( node -- ) node node-input-infos first literal>> dup expand-? [ :> len - ds-drop len emit-allot-byte-array :> reg len reg zero-byte-array ] [ drop node emit-primitive ] if ; From e2ceb113374da17e7749046b1af45e3764d5e383 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 15:57:44 -0400 Subject: [PATCH 16/18] stack-checker: calling 'boa' on a non-tuple would compile as a no-op rather than an error (reported by Joe Groff); clean up some other error reporting code too --- basis/compiler/tests/simple.factor | 5 ++++- basis/compiler/tests/tuples.factor | 6 ++++++ basis/stack-checker/backend/backend.factor | 12 +++++------- basis/stack-checker/known-words/known-words.factor | 7 +------ basis/stack-checker/transforms/transforms.factor | 4 +++- 5 files changed, 19 insertions(+), 15 deletions(-) diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index df67cadd78..8b1fc3569f 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler.test compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval quotations compiler.errors -definitions ; +definitions generic.single ; IN: compiler.tests.simple ! Test empty word @@ -249,3 +249,6 @@ M: quotation bad-effect-test call ; inline ! Don't want compiler error to stick around [ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test + +! Make sure time bombs literalize +[ [ \ + call ] compile-call ] [ no-method? ] must-fail-with diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index 978c27768f..e92057faf9 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -8,3 +8,9 @@ TUPLE: color red green blue ; [ T{ color f f f f } ] [ [ color new ] compile-call ] unit-test + +SYMBOL: foo + +[ [ foo new ] compile-call ] must-fail + +[ [ foo boa ] compile-call ] must-fail diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 7a18133eff..d757e02ca9 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -110,13 +110,11 @@ M: object apply-object push-literal ; infer-quot-here ] dip recursive-state set ; -: time-bomb ( error -- ) - '[ _ throw ] infer-quot-here ; +: time-bomb-quot ( obj generic -- quot ) + [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ; -ERROR: bad-call obj ; - -M: bad-call summary - drop "call must be given a callable" ; +: time-bomb ( obj generic -- ) + time-bomb-quot infer-quot-here ; : infer-literal-quot ( literal -- ) dup recursive-quotation? [ @@ -127,7 +125,7 @@ M: bad-call summary [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ - value>> \ bad-call boa time-bomb + value>> \ call time-bomb ] if ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 9791919392..4b43c4c2f1 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -156,17 +156,12 @@ M: object infer-call* \ call bad-macro-input ; \ compose [ infer-compose ] "special" set-word-prop -ERROR: bad-executable obj ; - -M: bad-executable summary - drop "execute must be given a word" ; - : infer-execute ( -- ) pop-literal nip dup word? [ apply-object ] [ - \ bad-executable boa time-bomb + \ execute time-bomb ] if ; \ execute [ infer-execute ] "special" set-word-prop diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 610d3f8600..d24be0e783 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -145,7 +145,9 @@ IN: stack-checker.transforms [ depends-on-tuple-layout ] [ [ "boa-check" word-prop [ ] or ] dip ] 2bi '[ @ _ ] - ] [ drop f ] if + ] [ + \ boa time-bomb + ] if ] 1 define-transform \ boa t "no-compile" set-word-prop From 88ca7abd5480a8f9dda8c8a2dade81737bb39949 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 16:08:36 -0400 Subject: [PATCH 17/18] ui.gadgets.worlds: dispose of the handle after ungrabbing input --- basis/ui/gadgets/worlds/worlds.factor | 11 ++++------- basis/ui/ui.factor | 2 +- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index e713b0f999..7e064ee76b 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -129,6 +129,7 @@ M: world request-focus-on ( child gadget -- ) [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ; GENERIC# apply-world-attributes 1 ( world attributes -- world ) + M: world apply-world-attributes { [ title>> >>title ] @@ -166,15 +167,11 @@ flush-layout-cache-hook [ [ ] ] initialize GENERIC: begin-world ( world -- ) GENERIC: end-world ( world -- ) - GENERIC: resize-world ( world -- ) -M: world begin-world - drop ; -M: world end-world - drop ; -M: world resize-world - drop ; +M: world begin-world drop ; +M: world end-world drop ; +M: world resize-world drop ; M: world dim<< [ call-next-method ] diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d65f4725a9..fad774cbcc 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -90,8 +90,8 @@ M: world ungraft* [ hand-gadget close-global ] [ end-world ] [ [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ] - [ [ (close-window) f ] change-handle drop ] [ unfocus-world ] + [ [ (close-window) f ] change-handle drop ] [ promise>> t swap fulfill ] } cleave ; From 35e5c572ce291dd0bc94d715b50d36edbad8a4a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 17 Jul 2010 16:09:25 -0400 Subject: [PATCH 18/18] ui: cleanup --- basis/ui/ui.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index fad774cbcc..68bb064328 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -81,6 +81,9 @@ M: world graft* [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover ] bi ; +: dispose-window-resources ( world -- ) + [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ; + M: world ungraft* { [ set-gl-context ] @@ -89,7 +92,7 @@ M: world ungraft* [ hand-clicked close-global ] [ hand-gadget close-global ] [ end-world ] - [ [ [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ] + [ dispose-window-resources ] [ unfocus-world ] [ [ (close-window) f ] change-handle drop ] [ promise>> t swap fulfill ]