diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index dc9d3e0d05..bf87cfd9f1 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -22,17 +22,11 @@ M: array c-type-align first c-type-align ; M: array c-type-align-first first c-type-align-first ; -M: array unbox-parameter drop void* unbox-parameter ; - -M: array unbox-return drop void* unbox-return ; - -M: array box-parameter drop void* box-parameter ; - -M: array box-return drop void* box-return ; +M: array base-type drop void* base-type ; M: array stack-size drop void* stack-size ; -M: array flatten-c-type drop { int-rep } ; +M: array flatten-c-type drop void* flatten-c-type ; PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; @@ -43,35 +37,19 @@ M: string-type c-type-class drop object ; M: string-type c-type-boxed-class drop object ; -M: string-type heap-size - drop void* heap-size ; +M: string-type heap-size drop void* heap-size ; -M: string-type c-type-align - drop void* c-type-align ; +M: string-type c-type-align drop void* c-type-align ; -M: string-type c-type-align-first - drop void* c-type-align-first ; +M: string-type c-type-align-first drop void* c-type-align-first ; -M: string-type unbox-parameter - drop void* unbox-parameter ; +M: string-type base-type drop void* base-type ; -M: string-type unbox-return - drop void* unbox-return ; +M: string-type stack-size drop void* stack-size ; -M: string-type box-parameter - drop void* box-parameter ; +M: string-type c-type-rep drop int-rep ; -M: string-type box-return - drop void* box-return ; - -M: string-type stack-size - drop void* stack-size ; - -M: string-type c-type-rep - drop int-rep ; - -M: string-type flatten-c-type - drop { int-rep } ; +M: string-type flatten-c-type drop void* flatten-c-type ; M: string-type c-type-boxer-quot second dup binary = diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 9592fb1812..bf26dd5f88 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -43,21 +43,6 @@ HELP: c-setter { $description "Outputs a quotation which writes values of this C type to a C structure." } { $errors "Throws an error if the type does not exist." } ; -HELP: box-parameter -{ $values { "n" math:integer } { "c-type" "a C type" } } -{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } -{ $notes "This is an internal word used by the compiler when compiling callbacks." } ; - -HELP: box-return -{ $values { "c-type" "a C type" } } -{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." } -{ $notes "This is an internal word used by the compiler when compiling alien calls." } ; - -HELP: unbox-return -{ $values { "c-type" "a C type" } } -{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." } -{ $notes "This is an internal word used by the compiler when compiling callbacks." } ; - HELP: define-deref { $values { "c-type" "a C type" } } { $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 98b15b7af8..d916ce9dec 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -111,27 +111,11 @@ GENERIC: c-type-align-first ( name -- n ) M: abstract-c-type c-type-align-first align-first>> ; -: c-type-box ( n c-type -- ) - [ rep>> ] [ boxer>> ] bi %box ; +GENERIC: base-type ( c-type -- c-type ) -: c-type-unbox ( n c-type -- ) - [ rep>> ] [ unboxer>> ] bi %unbox ; +M: c-type-name base-type c-type ; -GENERIC: box-parameter ( n c-type -- ) - -M: c-type box-parameter c-type-box ; - -GENERIC: box-return ( c-type -- ) - -M: c-type box-return f swap c-type-box ; - -GENERIC: unbox-parameter ( n c-type -- ) - -M: c-type unbox-parameter c-type-unbox ; - -GENERIC: unbox-return ( c-type -- ) - -M: c-type unbox-return f swap c-type-unbox ; +M: c-type base-type ; : little-endian? ( -- ? ) 1 *char 1 = ; foldable @@ -179,10 +163,7 @@ PROTOCOL: c-type-protocol c-type-setter c-type-align c-type-align-first - box-parameter - box-return - unbox-parameter - unbox-return + base-type heap-size stack-size flatten-c-type ; @@ -204,18 +185,6 @@ TUPLE: long-long-type < c-type ; : ( -- c-type ) long-long-type new ; -M: long-long-type unbox-parameter ( n c-type -- ) - unboxer>> %unbox-long-long ; - -M: long-long-type unbox-return ( c-type -- ) - f swap unbox-parameter ; - -M: long-long-type box-parameter ( n c-type -- ) - boxer>> %box-long-long ; - -M: long-long-type box-return ( c-type -- ) - f swap box-parameter ; - M: long-long-type flatten-c-type int-rep (flatten-c-type) ; diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 56109e2de6..9c753ce08f 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -117,6 +117,8 @@ gc " done" print flush + "alien.syntax" require + "alien.complex" require "io.streams.byte-array.fast" require ] unless diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index 553b91a6ae..f77829ae86 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -6,12 +6,10 @@ IN: bootstrap.help : load-help ( -- ) "help.lint" require "help.vocabs" require - "alien.syntax" require - "compiler" require t load-help? set-global - [ vocab ] load-vocab-hook [ + [ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [ dictionary get values [ docs-loaded?>> not ] filter [ load-docs ] each diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index a5a31ebd65..e76aace464 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -8,7 +8,7 @@ HELP: duration { $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; { timestamp duration } related-words diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 74b4882ffb..d33f6fa35d 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -169,20 +169,10 @@ M: struct-c-type c-type ; : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline -M: struct-c-type unbox-parameter - [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ; - -M: struct-c-type box-parameter - [ %box-large-struct ] [ box-parameter ] if-value-struct ; - : if-small-struct ( c-type true false -- ? ) [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline -M: struct-c-type unbox-return - [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; - -M: struct-c-type box-return - [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; +M: struct-c-type base-type ; M: struct-c-type stack-size [ heap-size cell align ] [ stack-size ] if-value-struct ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 3f98c3711f..54cff306ed 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -10,9 +10,9 @@ IN: compiler.cfg.block-joining ! before stack analysis. : join-block? ( bb -- ? ) { - [ kill-block? not ] + [ kill-block?>> not ] [ predecessors>> length 1 = ] - [ predecessor kill-block? not ] + [ predecessor kill-block?>> not ] [ predecessor successors>> length 1 = ] [ [ predecessor ] keep back-edge? not ] } 1&& ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 1daabf6f0e..b6cde4d435 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2009 Doug Coleman, Slava Pestov. +! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit kernel math math.order -sequences assocs namespaces vectors fry arrays splitting -compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors -compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; +USING: accessors combinators combinators.short-circuit kernel +math math.order sequences assocs namespaces vectors fry arrays +splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo +compiler.cfg.predecessors compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting : clone-instructions ( insns -- insns' ) @@ -15,10 +16,12 @@ IN: compiler.cfg.branch-splitting ! 'back-edge?' work. swap - [ instructions>> clone-instructions >>instructions ] - [ successors>> clone >>successors ] - [ number>> >>number ] - tri ; + { + [ instructions>> clone-instructions >>instructions ] + [ successors>> clone >>successors ] + [ kill-block?>> >>kill-block? ] + [ number>> >>number ] + } cleave ; : new-blocks ( bb -- copies ) dup predecessors>> [ 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 8f98ab7add..747e0f54cf 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -14,13 +14,7 @@ GENERIC: compute-stack-frame* ( insn -- ) frame-required? on stack-frame [ max-stack-frame ] change ; -UNION: stack-frame-insn - ##alien-invoke - ##alien-indirect - ##alien-assembly - ##alien-callback ; - -M: stack-frame-insn compute-stack-frame* +M: ##stack-frame compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* drop frame-required? on ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor new file mode 100644 index 0000000000..bf674fa9b9 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -0,0 +1,296 @@ +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays layouts math math.order math.parser +combinators fry sequences locals alien alien.private +alien.strings alien.c-types alien.libraries classes.struct +namespaces kernel strings libc quotations cpu.architecture +compiler.alien compiler.utilities compiler.tree compiler.cfg +compiler.cfg.builder compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.stack-frame +compiler.cfg.stacks compiler.cfg.registers +compiler.cfg.hats ; +FROM: compiler.errors => no-such-symbol no-such-library ; +IN: compiler.cfg.builder.alien + +GENERIC: next-fastcall-param ( rep -- ) + +: ?dummy-stack-params ( rep -- ) + dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; + +: ?dummy-int-params ( rep -- ) + dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; + +: ?dummy-fp-params ( rep -- ) + drop dummy-fp-params? [ float-regs inc ] when ; + +M: int-rep next-fastcall-param + int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; + +M: float-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +M: double-rep next-fastcall-param + float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; + +GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) + +M: stack-params reg-class-full? 2drop t ; + +M: reg-class reg-class-full? + [ get ] swap '[ _ param-regs length ] bi >= ; + +: alloc-stack-param ( rep -- n reg-class rep ) + stack-params get + [ rep-size cell align stack-params +@ ] dip + stack-params dup ; + +: alloc-fastcall-param ( rep -- n reg-class rep ) + [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; + +:: alloc-parameter ( rep abi -- reg rep ) + rep dup reg-class-of abi reg-class-full? + [ alloc-stack-param ] [ alloc-fastcall-param ] if + [ abi param-reg ] dip ; + +: reset-fastcall-counts ( -- ) + { int-regs float-regs stack-params } [ 0 swap set ] each ; + +: with-param-regs ( quot -- ) + #! In quot you can call alloc-parameter + [ reset-fastcall-counts call ] with-scope ; inline + +:: move-parameters ( params word -- ) + #! Moves values from C stack to registers (if word is + #! ##load-param-reg) and registers to C stack (if word is + #! ##save-param-reg). + 0 params alien-parameters flatten-c-types [ + [ params abi>> alloc-parameter word execute( offset reg rep -- ) ] + [ rep-size cell align + ] + 2bi + ] each drop ; inline + +: parameter-offsets ( types -- offsets ) + 0 [ stack-size + ] accumulate nip ; + +: prepare-parameters ( parameters -- offsets types indices ) + [ length iota ] [ parameter-offsets ] [ ] tri ; + +GENERIC: unbox-parameter ( src n c-type -- ) + +M: c-type unbox-parameter + [ rep>> ] [ unboxer>> ] bi ##unbox ; + +M: long-long-type unbox-parameter + unboxer>> ##unbox-long-long ; + +M: struct-c-type unbox-parameter + [ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ] + [ base-type unbox-parameter ] + if-value-struct ; + +: unbox-parameters ( offset node -- ) + parameters>> swap + '[ + prepare-parameters + [ + [ ^^peek ] [ _ + ] [ base-type ] tri* + unbox-parameter + ] 3each + ] + [ length neg ##inc-d ] + bi ; + +: prepare-box-struct ( node -- offset ) + #! Return offset on C stack where to store unboxed + #! parameters. If the C function is returning a structure, + #! the first parameter is an implicit target area pointer, + #! so we need to use a different offset. + return>> large-struct? + [ ##prepare-box-struct cell ] [ 0 ] if ; + +: objects>registers ( params -- ) + #! Generate code for unboxing a list of C types, then + #! generate code for moving these parameters to registers on + #! architectures where parameters are passed in registers. + [ + [ prepare-box-struct ] keep + [ unbox-parameters ] keep + \ ##load-param-reg move-parameters + ] with-param-regs ; + +GENERIC: box-return ( c-type -- dst ) + +M: c-type box-return + [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ; + +M: long-long-type box-return + [ f ] dip boxer>> ^^box-long-long ; + +M: struct-c-type box-return + [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ; + +: box-return* ( node -- ) + return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; + +GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) + +M: string dlsym-valid? dlsym ; + +M: array dlsym-valid? '[ _ dlsym ] any? ; + +: check-dlsym ( symbols dll -- ) + dup dll-valid? [ + dupd dlsym-valid? + [ drop ] [ cfg get word>> no-such-symbol ] if + ] [ dll-path cfg get word>> no-such-library drop ] if ; + +: decorated-symbol ( params -- symbols ) + [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi + { + [ drop ] + [ "@" glue ] + [ "@" glue "_" prepend ] + [ "@" glue "@" prepend ] + } 2cleave + 4array ; + +: alien-invoke-dlsym ( params -- symbols dll ) + [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] + [ library>> load-library ] + bi 2dup check-dlsym ; + +: return-size ( ctype -- n ) + #! Amount of space we reserve for a return value. + { + { [ dup c-struct? not ] [ drop 0 ] } + { [ dup large-struct? not ] [ drop 2 cells ] } + [ heap-size ] + } cond ; + +: ( params -- stack-frame ) + stack-frame new + swap + [ return>> return-size >>return ] + [ alien-parameters [ stack-size ] map-sum >>params ] bi + t >>calls-vm? ; + +: alien-node-height ( params -- ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + +: emit-alien-node ( node quot -- ) + '[ + make-kill-block + params>> + [ ##stack-frame ] + _ + [ alien-node-height ] + tri + ] emit-trivial-block ; inline + +M: #alien-invoke emit-node + [ + ! Unbox parameters + dup objects>registers + ! Call function + dup alien-invoke-dlsym ##alien-invoke + ! Box return value + dup ##cleanup + box-return* + ] emit-alien-node ; + +M: #alien-indirect emit-node + [ + D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr + { + [ drop objects>registers ] + [ nip ##alien-indirect ] + [ drop ##cleanup ] + [ drop box-return* ] + } 2cleave + ] emit-alien-node ; + +M: #alien-assembly emit-node + [ + [ objects>registers ] + [ quot>> ##alien-assembly ] + [ box-return* ] + tri + ] emit-alien-node ; + +GENERIC: box-parameter ( n c-type -- dst ) + +M: c-type box-parameter + [ rep>> ] [ boxer>> ] bi ^^box ; + +M: long-long-type box-parameter + boxer>> ^^box-long-long ; + +M: struct-c-type box-parameter + [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ; + +: box-parameters ( params -- ) + alien-parameters + [ length ##inc-d ] + [ + prepare-parameters + [ + next-vreg next-vreg ##save-context + base-type box-parameter swap ##replace + ] 3each + ] bi ; + +: registers>objects ( node -- ) + ! Generate code for boxing input parameters in a callback. + [ + dup \ ##save-param-reg move-parameters + ##begin-callback + next-vreg next-vreg ##restore-context + box-parameters + ] with-param-regs ; + +: callback-return-quot ( ctype -- quot ) + return>> { + { [ dup void? ] [ drop [ ] ] } + { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } + [ c-type c-type-unboxer-quot ] + } cond ; + +: callback-prep-quot ( params -- quot ) + parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; + +: wrap-callback-quot ( params -- quot ) + [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append + yield-hook get + '[ _ _ do-callback ] + >quotation ; + +GENERIC: unbox-return ( src c-type -- ) + +M: c-type unbox-return + [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ; + +M: long-long-type unbox-return + [ f ] dip unboxer>> ##unbox-long-long ; + +M: struct-c-type unbox-return + [ ^^unbox-any-c-ptr ] dip + [ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ; + +M: #alien-callback emit-node + dup params>> xt>> dup + [ + ##prologue + [ + [ registers>objects ] + [ wrap-callback-quot ##alien-callback ] + [ + alien-return [ ##end-callback ] [ + [ D 0 ^^peek ] dip + ##end-callback + base-type unbox-return + ] if-void + ] tri + ] emit-alien-node + ##epilogue + ##return + ] with-cfg-builder ; diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 8e96255bdd..293c3fe09b 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.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 fry kernel make math namespaces sequences compiler.cfg compiler.cfg.instructions compiler.cfg.stacks @@ -31,6 +31,9 @@ IN: compiler.cfg.builder.blocks call ##branch begin-basic-block ; inline +: make-kill-block ( -- ) + basic-block get t >>kill-block? drop ; + : call-height ( #call -- n ) [ out-d>> length ] [ in-d>> length ] bi - ; @@ -38,6 +41,7 @@ IN: compiler.cfg.builder.blocks [ [ word>> ##call ] [ call-height adjust-d ] bi + make-kill-block ] emit-trivial-block ; : begin-branch ( -- ) clone-current-height (begin-basic-block) ; @@ -66,7 +70,7 @@ IN: compiler.cfg.builder.blocks [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; : emit-conditional ( branches -- ) - ! branchies is a sequence of pairs as above + ! branches is a sequence of pairs as above end-basic-block [ merge-heights begin-basic-block ] [ set-successors ] diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index c0ba1144a5..059a7f2215 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -57,6 +57,7 @@ GENERIC: emit-node ( node -- ) [ basic-block get [ emit-node ] [ drop ] if ] each ; : begin-word ( -- ) + make-kill-block ##prologue ##branch begin-basic-block ; @@ -82,8 +83,12 @@ GENERIC: emit-node ( node -- ) : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] - [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] - if ; + [ + [ + [ ##call ] [ adjust-d ] bi* + make-kill-block + ] emit-trivial-block + ] if ; ! #recursive : recursive-height ( #recursive -- n ) @@ -195,7 +200,11 @@ M: #shuffle emit-node ! #return : emit-return ( -- ) - ##branch begin-basic-block ##epilogue ##return ; + ##branch + begin-basic-block + make-kill-block + ##epilogue + ##return ; M: #return emit-node drop emit-return ; @@ -205,49 +214,6 @@ M: #return-recursive emit-node ! #terminate M: #terminate emit-node drop ##no-tco end-basic-block ; -! FFI -: return-size ( ctype -- n ) - #! Amount of space we reserve for a return value. - { - { [ dup c-struct? not ] [ drop 0 ] } - { [ dup large-struct? not ] [ drop 2 cells ] } - [ heap-size ] - } cond ; - -: ( params -- stack-frame ) - stack-frame new - swap - [ return>> return-size >>return ] - [ alien-parameters [ stack-size ] map-sum >>params ] bi - t >>calls-vm? ; - -: alien-node-height ( params -- ) - [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; - -: emit-alien-node ( node quot -- ) - [ - [ params>> dup dup ] dip call - alien-node-height - ] emit-trivial-block ; inline - -M: #alien-invoke emit-node - [ ##alien-invoke ] emit-alien-node ; - -M: #alien-indirect emit-node - [ ##alien-indirect ] emit-alien-node ; - -M: #alien-assembly emit-node - [ ##alien-assembly ] emit-alien-node ; - -M: #alien-callback emit-node - dup params>> xt>> dup - [ - ##prologue - [ ##alien-callback ] emit-alien-node - ##epilogue - ##return - ] with-cfg-builder ; - ! No-op nodes M: #introduce emit-node drop ; diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index c49d638509..5f5283bcd5 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -9,6 +9,7 @@ number { instructions vector } { successors vector } { predecessors vector } +{ kill-block? boolean } { unlikely? boolean } ; : ( -- bb ) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index d7a48a1511..f4fee8b7b2 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -7,50 +7,11 @@ compiler.cfg.utilities compiler.cfg.finalization compiler.utilities ; IN: compiler.cfg.checker -! Check invariants - -ERROR: bad-kill-block bb ; - -: check-kill-block ( bb -- ) - dup instructions>> dup penultimate ##epilogue? [ - { - [ length 2 = ] - [ last { [ ##return? ] [ ##jump? ] } 1|| ] - } 1&& - ] [ last ##branch? ] if - [ drop ] [ bad-kill-block ] if ; - -ERROR: last-insn-not-a-jump bb ; - -: check-last-instruction ( bb -- ) - dup instructions>> last { - [ ##branch? ] - [ ##dispatch? ] - [ conditional-branch-insn? ] - [ ##no-tco? ] - } 1|| [ drop ] [ last-insn-not-a-jump ] if ; - -ERROR: bad-kill-insn bb ; - -: check-kill-instructions ( bb -- ) - dup instructions>> [ kill-vreg-insn? ] any? - [ bad-kill-insn ] [ drop ] if ; - -: check-normal-block ( bb -- ) - [ check-last-instruction ] - [ check-kill-instructions ] - bi ; - ERROR: bad-successors ; : check-successors ( bb -- ) dup successors>> [ predecessors>> member-eq? ] with all? [ bad-successors ] unless ; -: check-basic-block ( bb -- ) - [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ] - [ check-successors ] - bi ; - : check-cfg ( cfg -- ) - [ check-basic-block ] each-basic-block ; + [ check-successors ] each-basic-block ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index dde44fd15d..553b843833 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -18,27 +18,21 @@ MIXIN: dataflow-analysis : ( cfg dfa -- queue ) block-order [ push-all-front ] keep ; -GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) - -M: kill-block compute-in-set 3drop f ; - -M:: basic-block compute-in-set ( bb out-sets dfa -- set ) +:: compute-in-set ( bb out-sets dfa -- set ) ! Only consider initialized sets. - bb dfa predecessors - [ out-sets key? ] filter - [ out-sets at ] map - bb dfa join-sets ; + bb kill-block?>> [ f ] [ + bb dfa predecessors + [ out-sets key? ] filter + [ out-sets at ] map + bb dfa join-sets + ] if ; :: update-in-set ( bb in-sets out-sets dfa -- ? ) bb out-sets dfa compute-in-set bb in-sets maybe-set-at ; inline -GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) - -M: kill-block compute-out-set 3drop f ; - -M:: basic-block compute-out-set ( bb in-sets dfa -- set ) - bb in-sets at bb dfa transfer-set ; +:: compute-out-set ( bb in-sets dfa -- set ) + bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ; :: update-out-set ( bb in-sets out-sets dfa -- ? ) bb in-sets dfa compute-out-set diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d4e019d8dd..36e840fc9e 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -34,6 +34,10 @@ INSN: ##load-tagged def: dst/tagged-rep literal: val ; +INSN: ##load-float +def: dst/float-rep +literal: val ; + INSN: ##load-double def: dst/double-rep literal: val ; @@ -605,17 +609,67 @@ use: src/tagged-rep literal: offset ; ! FFI +INSN: ##stack-frame +literal: stack-frame ; + +INSN: ##box +def: dst/tagged-rep +literal: n rep boxer ; + +INSN: ##box-long-long +def: dst/tagged-rep +literal: n boxer ; + +INSN: ##box-small-struct +def: dst/tagged-rep +literal: c-type ; + +INSN: ##box-large-struct +def: dst/tagged-rep +literal: n c-type ; + +INSN: ##unbox +use: src/tagged-rep +literal: n rep unboxer ; + +INSN: ##unbox-long-long +use: src/tagged-rep +literal: n unboxer ; + +INSN: ##unbox-large-struct +use: src/int-rep +literal: n c-type ; + +INSN: ##unbox-small-struct +use: src/int-rep +literal: c-type ; + +INSN: ##prepare-box-struct ; + +INSN: ##load-param-reg +literal: offset reg rep ; + INSN: ##alien-invoke -literal: params stack-frame ; +literal: symbols dll ; + +INSN: ##cleanup +literal: params ; INSN: ##alien-indirect -literal: params stack-frame ; +use: src/int-rep ; INSN: ##alien-assembly -literal: params stack-frame ; +literal: quot ; + +INSN: ##save-param-reg +literal: offset reg rep ; + +INSN: ##begin-callback ; INSN: ##alien-callback -literal: params stack-frame ; +literal: quot ; + +INSN: ##end-callback ; ! Control flow INSN: ##phi @@ -706,6 +760,9 @@ literal: cc ; INSN: ##save-context temp: temp1/int-rep temp2/int-rep ; +INSN: ##restore-context +temp: temp1/int-rep temp2/int-rep ; + ! GC checks INSN: ##check-nursery-branch literal: size cc @@ -752,16 +809,23 @@ UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; UNION: clobber-insn ##call-gc ##unary-float-function -##binary-float-function ; - -! Instructions that kill all live vregs -UNION: kill-vreg-insn -##call -##prologue -##epilogue +##binary-float-function +##box +##box-long-long +##box-small-struct +##box-large-struct +##unbox +##unbox-long-long +##unbox-large-struct +##unbox-small-struct +##prepare-box-struct +##load-param-reg ##alien-invoke ##alien-indirect -##alien-callback ; +##alien-assembly +##save-param-reg +##begin-callback +##end-callback ; ! 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/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index b9cfac3b92..6b87ca8fd6 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -51,7 +51,11 @@ IN: compiler.cfg.intrinsics.fixnum [ ds-drop ds-drop ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ ##call -1 adjust-d ] with-branch ; + [ + ##call + -1 adjust-d + make-kill-block + ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) ! Inputs to the final instruction need to be copied because diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index ed7690bd77..c1b3f04ff4 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -35,10 +35,9 @@ IN: compiler.cfg.linear-scan.allocation } cond ; : spill-at-sync-point ( live-interval n -- ? ) - ! If the live interval has a usage at 'n', don't spill it, - ! since this means its being defined by the sync point - ! instruction. Output t if this is the case. - 2dup [ uses>> ] dip '[ n>> _ = ] any? + ! If the live interval has a definition at 'n', don't spill + 2dup [ uses>> ] dip + '[ [ def-rep>> ] [ n>> _ = ] bi and ] any? [ 2drop t ] [ spill f ] if ; : handle-sync-point ( n -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 3ab4005359..be5ab9d481 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -28,14 +28,20 @@ ERROR: bad-live-ranges interval ; [ swap first from<< ] 2bi ; +: last-use-rep ( live-interval -- rep/f ) + last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline + : assign-spill ( live-interval -- ) - dup [ vreg>> ] [ last-use rep>> ] bi - assign-spill-slot >>spill-to drop ; + dup last-use-rep dup [ + >>spill-rep + dup [ vreg>> ] [ spill-rep>> ] bi + assign-spill-slot >>spill-to drop + ] [ 2drop ] if ; : spill-before ( before -- before/f ) ! If the interval does not have any usages before the spill location, ! then it is the second child of an interval that was split. We reload - ! the value and let the resolve pass insert a split later. + ! the value and let the resolve pass insert a spill later. dup uses>> empty? [ drop f ] [ { [ ] @@ -46,9 +52,15 @@ ERROR: bad-live-ranges interval ; } cleave ] if ; +: first-use-rep ( live-interval -- rep/f ) + first-use use-rep>> ; inline + : assign-reload ( live-interval -- ) - dup [ vreg>> ] [ first-use rep>> ] bi - assign-spill-slot >>reload-from drop ; + dup first-use-rep dup [ + >>reload-rep + dup [ vreg>> ] [ reload-rep>> ] bi + assign-spill-slot >>reload-from drop + ] [ 2drop ] if ; : spill-after ( after -- after/f ) ! If the interval has no more usages after the spill location, diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index d41a06806b..6346ea41f5 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators fry hints kernel locals +USING: accessors arrays assocs combinators +combinators.short-circuit fry hints kernel locals math sequences sets sorting splitting namespaces compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -25,7 +26,9 @@ IN: compiler.cfg.linear-scan.allocation.splitting ] bi ; : split-uses ( uses n -- before after ) - '[ n>> _ <= ] partition ; + [ '[ n>> _ < ] filter ] + [ '[ n>> _ > ] filter ] + 2bi ; ERROR: splitting-too-early ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 1682cf9eb6..1780a1c907 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -93,7 +93,7 @@ SYMBOL: machine-live-outs init-unhandled ; : insert-spill ( live-interval -- ) - [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ; + [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ; : handle-spill ( live-interval -- ) dup spill-to>> [ insert-spill ] [ drop ] if ; @@ -113,18 +113,10 @@ SYMBOL: machine-live-outs pending-interval-heap get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ; - -: insert-reload? ( live-interval -- ? ) - ! Don't insert a reload if the register will be written to - ! before being read again. - { - [ reload-from>> ] - [ first-use type>> +use+ eq? ] - } 1&& ; + [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ; : handle-reload ( live-interval -- ) - dup insert-reload? [ insert-reload ] [ drop ] if ; + dup reload-from>> [ insert-reload ] [ drop ] if ; : activate-interval ( live-interval -- ) [ add-pending ] [ handle-reload ] bi ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 9e6ec76d2c..11e190d226 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -91,18 +91,20 @@ H{ { reg-class float-regs } { start 0 } { end 2 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } } { ranges V{ T{ live-range f 0 2 } } } { spill-to T{ spill-slot f 0 } } + { spill-rep float-rep } } T{ live-interval { vreg 1 } { reg-class float-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 5 5 } } } { reload-from T{ spill-slot f 0 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -110,29 +112,22 @@ H{ { reg-class float-regs } { start 0 } { end 5 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 0 5 } } } } 2 split-for-spill ] unit-test [ - T{ live-interval - { vreg 2 } - { reg-class float-regs } - { start 0 } - { end 1 } - { uses V{ T{ vreg-use f float-rep 0 } } } - { ranges V{ T{ live-range f 0 1 } } } - { spill-to T{ spill-slot f 4 } } - } + f T{ live-interval { vreg 2 } { reg-class float-regs } { start 1 } { end 5 } - { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 1 5 } } } { reload-from T{ spill-slot f 4 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -140,7 +135,7 @@ H{ { reg-class float-regs } { start 0 } { end 5 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } { ranges V{ T{ live-range f 0 5 } } } } 0 split-for-spill ] unit-test @@ -151,18 +146,20 @@ H{ { reg-class float-regs } { start 0 } { end 1 } - { uses V{ T{ vreg-use f float-rep 0 } } } + { uses V{ T{ vreg-use f 0 float-rep f } } } { ranges V{ T{ live-range f 0 1 } } } { spill-to T{ spill-slot f 8 } } + { spill-rep float-rep } } T{ live-interval { vreg 3 } { reg-class float-regs } { start 20 } { end 30 } - { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } + { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } { ranges V{ T{ live-range f 20 30 } } } { reload-from T{ spill-slot f 8 } } + { reload-rep float-rep } } ] [ T{ live-interval @@ -170,11 +167,75 @@ H{ { reg-class float-regs } { start 0 } { end 30 } - { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } } 10 split-for-spill ] unit-test +! Don't insert reload if first usage is a def +[ + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 0 } + { end 1 } + { uses V{ T{ vreg-use f 0 float-rep f } } } + { ranges V{ T{ live-range f 0 1 } } } + { spill-to T{ spill-slot f 12 } } + { spill-rep float-rep } + } + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 20 } + { end 30 } + { uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 20 30 } } } + } +] [ + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 0 } + { end 30 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } + } 10 split-for-spill +] unit-test + +! Multiple representations +[ + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 0 } + { end 11 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } } + { ranges V{ T{ live-range f 0 11 } } } + { spill-to T{ spill-slot f 16 } } + { spill-rep double-rep } + } + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 20 } + { end 20 } + { uses V{ T{ vreg-use f 20 f double-rep } } } + { ranges V{ T{ live-range f 20 20 } } } + { reload-from T{ spill-slot f 16 } } + { reload-rep double-rep } + } +] [ + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 0 } + { end 20 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } T{ vreg-use f 20 f double-rep } } } + { ranges V{ T{ live-range f 0 20 } } } + } 15 split-for-spill +] unit-test + H{ { 1 int-rep } { 2 int-rep } @@ -196,7 +257,7 @@ H{ { reg 1 } { start 1 } { end 15 } - { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } } + { uses V{ T{ vreg-use f 1 int-rep f } T{ vreg-use f 3 f int-rep } T{ vreg-use f 7 f int-rep } T{ vreg-use f 10 f int-rep } T{ vreg-use f 15 f int-rep } } } } T{ live-interval { vreg 2 } @@ -204,7 +265,7 @@ H{ { reg 2 } { start 3 } { end 8 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 4 f int-rep } T{ vreg-use f 8 f int-rep } } } } T{ live-interval { vreg 3 } @@ -212,7 +273,7 @@ H{ { reg 3 } { start 3 } { end 10 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 10 f int-rep } } } } } } @@ -223,7 +284,7 @@ H{ { reg-class int-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f int-rep 5 } } } + { uses V{ T{ vreg-use f 5 int-rep f } } } } spill-status ] unit-test @@ -243,7 +304,7 @@ H{ { reg 1 } { start 1 } { end 15 } - { uses V{ T{ vreg-use f int-rep 1 } } } + { uses V{ T{ vreg-use f 1 int-rep f } } } } T{ live-interval { vreg 2 } @@ -251,7 +312,7 @@ H{ { reg 2 } { start 3 } { end 8 } - { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 8 f int-rep } } } } } } @@ -262,7 +323,7 @@ H{ { reg-class int-regs } { start 5 } { end 5 } - { uses V{ T{ vreg-use f int-rep 5 } } } + { uses V{ T{ vreg-use f 5 int-rep f } } } } spill-status ] unit-test @@ -276,7 +337,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } } @@ -291,7 +352,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 10 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } } } { ranges V{ T{ live-range f 0 10 } } } } T{ live-interval @@ -299,7 +360,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 11 } { end 20 } - { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 11 int-rep f } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 11 20 } } } } } @@ -314,7 +375,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -322,7 +383,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 60 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 60 f int-rep } } } { ranges V{ T{ live-range f 30 60 } } } } } @@ -337,7 +398,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -345,7 +406,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 200 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 200 f int-rep } } } { ranges V{ T{ live-range f 30 200 } } } } } @@ -360,7 +421,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 0 } { end 100 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 0 100 } } } } T{ live-interval @@ -368,7 +429,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set { reg-class int-regs } { start 30 } { end 100 } - { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } } + { uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 100 f int-rep } } } { ranges V{ T{ live-range f 30 100 } } } } } @@ -392,7 +453,7 @@ H{ { reg-class int-regs } { start 0 } { end 20 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval @@ -400,7 +461,7 @@ H{ { reg-class int-regs } { start 0 } { end 20 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } } { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } } } T{ live-interval @@ -408,7 +469,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 6 } } } + { uses V{ T{ vreg-use f 6 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } T{ live-interval @@ -416,7 +477,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } @@ -426,7 +487,7 @@ H{ { reg-class int-regs } { start 4 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 4 8 } } } } } @@ -443,7 +504,7 @@ H{ { reg-class int-regs } { start 0 } { end 10 } - { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 6 f int-rep } T{ vreg-use f 10 f int-rep } } } { ranges V{ T{ live-range f 0 10 } } } } @@ -453,7 +514,7 @@ H{ { reg-class int-regs } { start 2 } { end 8 } - { uses V{ T{ vreg-use f int-rep 8 } } } + { uses V{ T{ vreg-use f 8 int-rep f } } } { ranges V{ T{ live-range f 2 8 } } } } } @@ -595,7 +656,7 @@ H{ { start 8 } { end 10 } { ranges V{ T{ live-range f 8 10 } } } - { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } } + { uses V{ T{ vreg-use f 8 int-rep f } T{ vreg-use f 10 f int-rep } } } } register-status ] unit-test 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 c4b255d12a..50efbd43e4 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -16,15 +16,13 @@ TUPLE: live-range from to ; C: live-range -SYMBOLS: +def+ +use+ +memory+ ; +TUPLE: vreg-use n def-rep use-rep ; -TUPLE: vreg-use rep n type ; - -C: vreg-use +: ( n -- vreg-use ) vreg-use new swap >>n ; TUPLE: live-interval vreg -reg spill-to reload-from +reg spill-to spill-rep reload-from reload-rep start end ranges uses reg-class ; @@ -32,6 +30,15 @@ reg-class ; : last-use ( live-interval -- use ) uses>> last ; inline +: new-use ( insn# uses -- use ) + [ dup ] dip push ; + +: last-use? ( insn# uses -- use/f ) + [ drop f ] [ last [ n>> = ] keep and ] if-empty ; + +: (add-use) ( insn# live-interval -- use ) + uses>> 2dup last-use? dup [ 2nip ] [ drop new-use ] if ; + GENERIC: covers? ( insn# obj -- ? ) M: f covers? 2drop f ; @@ -67,12 +74,6 @@ M: live-interval covers? ( insn# live-interval -- ? ) 2dup extend-range? [ extend-range ] [ add-new-range ] if ; -:: add-use ( rep n type live-interval -- ) - type +memory+ eq? [ - rep n type - live-interval uses>> push - ] unless ; - : ( vreg reg-class -- live-interval ) \ live-interval new V{ } clone >>uses @@ -97,40 +98,30 @@ GENERIC: compute-live-intervals* ( insn -- ) M: insn compute-live-intervals* drop ; -:: record-def ( vreg n type -- ) - vreg rep-of :> rep +:: record-def ( vreg n -- ) vreg live-interval :> live-interval n live-interval shorten-range - rep n type live-interval add-use ; + n live-interval (add-use) vreg rep-of >>def-rep drop ; -:: record-use ( vreg n type -- ) - vreg rep-of :> rep +:: record-use ( vreg n -- ) vreg live-interval :> live-interval from get n live-interval add-range - rep n type live-interval add-use ; + n live-interval (add-use) vreg rep-of >>use-rep drop ; :: record-temp ( vreg n -- ) - vreg rep-of :> rep vreg live-interval :> live-interval n n live-interval add-range - rep n +def+ live-interval add-use ; + n live-interval (add-use) vreg rep-of >>def-rep drop ; -M:: vreg-insn compute-live-intervals* ( insn -- ) - insn insn#>> :> n - - insn defs-vreg [ n +def+ record-def ] when* - insn uses-vregs [ n +use+ record-use ] each - insn temp-vregs [ n record-temp ] each ; - -M:: clobber-insn compute-live-intervals* ( insn -- ) - insn insn#>> :> n - - insn defs-vreg [ n +use+ record-def ] when* - insn uses-vregs [ n +memory+ record-use ] each - insn temp-vregs [ n record-temp ] each ; +M: vreg-insn compute-live-intervals* ( insn -- ) + dup insn#>> + [ [ defs-vreg ] dip '[ _ record-def ] when* ] + [ [ uses-vregs ] dip '[ _ record-use ] each ] + [ [ temp-vregs ] dip '[ _ record-temp ] each ] + 2tri ; : handle-live-out ( bb -- ) live-out dup assoc-empty? [ drop ] [ diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor index 22366f5714..c3e7fa06a5 100644 --- a/basis/compiler/cfg/representations/peephole/peephole.factor +++ b/basis/compiler/cfg/representations/peephole/peephole.factor @@ -42,8 +42,16 @@ M: ##load-integer optimize-insn [ call-next-method ] } cond ; -! When a float is unboxed, we replace the ##load-reference with a ##load-double -! if the architecture supports it +! When a constant float is unboxed, we replace the +! ##load-reference with a ##load-float or ##load-double if the +! architecture supports it +: convert-to-load-float? ( insn -- ? ) + { + [ drop fused-unboxing? ] + [ dst>> rep-of float-rep? ] + [ obj>> float? ] + } 1&& ; + : convert-to-load-double? ( insn -- ? ) { [ drop fused-unboxing? ] @@ -74,6 +82,10 @@ M: ##load-integer optimize-insn M: ##load-reference optimize-insn { + { + [ dup convert-to-load-float? ] + [ [ dst>> ] [ obj>> ] bi ##load-float here ] + } { [ dup convert-to-load-double? ] [ [ dst>> ] [ obj>> ] bi ##load-double here ] diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor index b0da0d190a..06444c66f8 100644 --- a/basis/compiler/cfg/representations/rewrite/rewrite.factor +++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor @@ -90,15 +90,14 @@ M: ##copy conversions-for-insn , ; M: insn conversions-for-insn , ; : conversions-for-block ( bb -- ) - dup kill-block? [ drop ] [ + [ [ - [ - H{ } clone alternatives set - [ conversions-for-insn ] each - ] V{ } make - ] change-instructions drop - ] if ; + alternatives get clear-assoc + [ conversions-for-insn ] each + ] V{ } make + ] change-instructions drop ; : insert-conversions ( cfg -- ) + H{ } clone alternatives set V{ } clone renaming-set set [ conversions-for-block ] each-basic-block ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index a76beca181..6d449540f2 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -36,8 +36,10 @@ SYMBOL: visited [ reverse-post-order ] dip each ; inline : optimize-basic-block ( bb quot -- ) - [ drop basic-block set ] - [ change-instructions drop ] 2bi ; inline + over kill-block?>> [ 2drop ] [ + over basic-block set + change-instructions drop + ] if ; inline : simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... ) '[ _ optimize-basic-block ] each-basic-block ; inline diff --git a/basis/compiler/cfg/scheduling/scheduling.factor b/basis/compiler/cfg/scheduling/scheduling.factor index 1c6c6987f7..04e4142a35 100644 --- a/basis/compiler/cfg/scheduling/scheduling.factor +++ b/basis/compiler/cfg/scheduling/scheduling.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2009, 2010 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs compiler.cfg.def-use -compiler.cfg.dependence compiler.cfg.instructions -compiler.cfg.liveness compiler.cfg.rpo cpu.architecture fry -kernel locals make math namespaces sequences sets ; +USING: accessors arrays assocs fry kernel locals make math +namespaces sequences sets combinators.short-circuit +compiler.cfg.def-use compiler.cfg.dependence +compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo +cpu.architecture ; IN: compiler.cfg.scheduling ! Instruction scheduling to reduce register pressure, from: @@ -128,7 +129,6 @@ ERROR: definition-after-usage vreg old-bb new-bb ; : schedule-instructions ( cfg -- cfg' ) dup [ - dup might-spill? - [ schedule-block ] - [ drop ] if + dup { [ kill-block?>> not ] [ might-spill? ] } 1&& + [ schedule-block ] [ drop ] if ] each-basic-block ; diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index 41512f206f..a35d82bbb5 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -43,7 +43,7 @@ ERROR: bad-peek dst loc ; : visit-edge ( from to -- ) ! If both blocks are subroutine calls, don't bother ! computing anything. - 2dup [ kill-block? ] both? [ 2drop ] [ + 2dup [ kill-block?>> ] both? [ 2drop ] [ 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ] if ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 0158c0546c..38ca9a950f 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -6,12 +6,6 @@ sets vectors fry arrays compiler.cfg compiler.cfg.instructions compiler.cfg.rpo compiler.utilities ; IN: compiler.cfg.utilities -PREDICATE: kill-block < basic-block - instructions>> { - [ length 2 >= ] - [ penultimate kill-vreg-insn? ] - } 1&& ; - : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor deleted file mode 100644 index 3af220376c..0000000000 --- a/basis/compiler/codegen/alien/alien.factor +++ /dev/null @@ -1,207 +0,0 @@ -! Copyright (C) 2008, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.complex alien.c-types -alien.libraries alien.private alien.strings arrays -classes.struct combinators compiler.alien -compiler.cfg.instructions compiler.codegen -compiler.codegen.fixup compiler.errors compiler.utilities -cpu.architecture fry kernel layouts libc locals make math -math.order math.parser namespaces quotations sequences strings -system ; -FROM: compiler.errors => no-such-symbol ; -IN: compiler.codegen.alien - -! ##alien-invoke -GENERIC: next-fastcall-param ( rep -- ) - -: ?dummy-stack-params ( rep -- ) - dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; - -: ?dummy-int-params ( rep -- ) - dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; - -: ?dummy-fp-params ( rep -- ) - drop dummy-fp-params? [ float-regs inc ] when ; - -M: int-rep next-fastcall-param - int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; - -M: float-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; - -M: double-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; - -GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) - -M: stack-params reg-class-full? 2drop t ; - -M: reg-class reg-class-full? - [ get ] swap '[ _ param-regs length ] bi >= ; - -: alloc-stack-param ( rep -- n reg-class rep ) - stack-params get - [ rep-size cell align stack-params +@ ] dip - stack-params dup ; - -: alloc-fastcall-param ( rep -- n reg-class rep ) - [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; - -:: alloc-parameter ( rep abi -- reg rep ) - rep dup reg-class-of abi reg-class-full? - [ alloc-stack-param ] [ alloc-fastcall-param ] if - [ abi param-reg ] dip ; - -: reset-fastcall-counts ( -- ) - { int-regs float-regs stack-params } [ 0 swap set ] each ; - -: with-param-regs ( quot -- ) - #! In quot you can call alloc-parameter - [ reset-fastcall-counts call ] with-scope ; inline - -:: move-parameters ( params word -- ) - #! Moves values from C stack to registers (if word is - #! %load-param-reg) and registers to C stack (if word is - #! %save-param-reg). - 0 params alien-parameters flatten-c-types [ - [ params abi>> alloc-parameter word execute( offset reg rep -- ) ] - [ rep-size cell align + ] - 2bi - ] each drop ; inline - -: parameter-offsets ( types -- offsets ) - 0 [ stack-size + ] accumulate nip ; - -: each-parameter ( parameters quot -- ) - [ [ parameter-offsets ] keep ] dip 2each ; inline - -: reverse-each-parameter ( parameters quot -- ) - [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline - -: prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets ] [ ] [ length iota ] tri ; - -: unbox-parameters ( offset node -- ) - parameters>> swap - '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ] - [ length neg %inc-d ] - bi ; - -: prepare-box-struct ( node -- offset ) - #! Return offset on C stack where to store unboxed - #! parameters. If the C function is returning a structure, - #! the first parameter is an implicit target area pointer, - #! so we need to use a different offset. - return>> large-struct? - [ %prepare-box-struct cell ] [ 0 ] if ; - -: objects>registers ( params -- ) - #! Generate code for unboxing a list of C types, then - #! generate code for moving these parameters to registers on - #! architectures where parameters are passed in registers. - [ - [ prepare-box-struct ] keep - [ unbox-parameters ] keep - \ %load-param-reg move-parameters - ] with-param-regs ; - -: box-return* ( node -- ) - return>> [ ] [ box-return %push-stack ] if-void ; - -GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) - -M: string dlsym-valid? dlsym ; - -M: array dlsym-valid? '[ _ dlsym ] any? ; - -: check-dlsym ( symbols dll -- ) - dup dll-valid? [ - dupd dlsym-valid? - [ drop ] [ compiling-word get no-such-symbol ] if - ] [ - dll-path compiling-word get no-such-library drop - ] if ; - -: decorated-symbol ( params -- symbols ) - [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi - { - [ drop ] - [ "@" glue ] - [ "@" glue "_" prepend ] - [ "@" glue "@" prepend ] - } 2cleave - 4array ; - -: alien-invoke-dlsym ( params -- symbols dll ) - [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] - [ library>> load-library ] - bi 2dup check-dlsym ; - -M: ##alien-invoke generate-insn - params>> - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Call function - dup alien-invoke-dlsym %alien-invoke - ! Box return value - dup %cleanup - box-return* ; - -M: ##alien-assembly generate-insn - params>> - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Generate assembly - dup quot>> call( -- ) - ! Box return value - box-return* ; - -! ##alien-indirect -M: ##alien-indirect generate-insn - params>> - ! Save alien at top of stack to temporary storage - %prepare-alien-indirect - ! Unbox parameters - dup objects>registers - %prepare-var-args - ! Call alien in temporary storage - %alien-indirect - ! Box return value - dup %cleanup - box-return* ; - -! ##alien-callback -: box-parameters ( params -- ) - alien-parameters [ box-parameter %push-context-stack ] each-parameter ; - -: registers>objects ( node -- ) - ! Generate code for boxing input parameters in a callback. - [ - dup \ %save-param-reg move-parameters - %begin-callback - box-parameters - ] with-param-regs ; - -: callback-return-quot ( ctype -- quot ) - return>> { - { [ dup void? ] [ drop [ ] ] } - { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } - [ c-type c-type-unboxer-quot ] - } cond ; - -: callback-prep-quot ( params -- quot ) - parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; - -: wrap-callback-quot ( params -- quot ) - [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append - yield-hook get - '[ _ _ do-callback ] - >quotation ; - -M: ##alien-callback generate-insn - params>> - [ registers>objects ] - [ wrap-callback-quot %alien-callback ] - [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ; diff --git a/basis/compiler/codegen/alien/authors.txt b/basis/compiler/codegen/alien/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/compiler/codegen/alien/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index 43473ebcbb..a02462dc08 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -2,13 +2,13 @@ USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make compiler.constants words ; IN: compiler.codegen.tests -[ ] [ gensym [ ] with-fixup drop ] unit-test -[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test +[ ] [ [ ] with-fixup drop ] unit-test +[ ] [ [ \ + %call ] with-fixup drop ] unit-test -[ ] [ gensym [