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 ;
M: string-type c-type-boxed-class drop object ;
-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-first
- drop void* c-type-align-first ;
-
-M: string-type unbox-parameter
- drop void* unbox-parameter ;
+M: string-type heap-size drop void* heap-size ;
-M: string-type unbox-return
- drop void* unbox-return ;
+M: string-type c-type-align drop void* c-type-align ;
-M: string-type box-parameter
- drop void* box-parameter ;
+M: string-type c-type-align-first drop void* c-type-align-first ;
-M: string-type box-return
- drop void* box-return ;
+M: string-type base-type drop void* base-type ;
-M: string-type stack-size
- drop void* stack-size ;
+M: string-type stack-size drop void* stack-size ;
-M: string-type c-type-rep
- drop int-rep ;
+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 =
{ $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." }
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 <int> *char 1 = ; foldable
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 ;
: <long-long-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) ;
" done" print flush
+ "alien.syntax" require
+ "alien.complex" require
"io.streams.byte-array.fast" require
] unless
: 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
{ $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
: 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 ;
! 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&& ;
-! 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' )
! 'back-edge?' work.
<basic-block>
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>> [
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 ;
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays layouts math math.order math.parser\r
+combinators fry sequences locals alien alien.private\r
+alien.strings alien.c-types alien.libraries classes.struct\r
+namespaces kernel strings libc quotations cpu.architecture\r
+compiler.alien compiler.utilities compiler.tree compiler.cfg\r
+compiler.cfg.builder compiler.cfg.builder.blocks\r
+compiler.cfg.instructions compiler.cfg.stack-frame\r
+compiler.cfg.stacks compiler.cfg.registers\r
+compiler.cfg.hats ;\r
+FROM: compiler.errors => no-such-symbol no-such-library ;\r
+IN: compiler.cfg.builder.alien\r
+\r
+GENERIC: next-fastcall-param ( rep -- )\r
+\r
+: ?dummy-stack-params ( rep -- )\r
+ dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;\r
+\r
+: ?dummy-int-params ( rep -- )\r
+ dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;\r
+\r
+: ?dummy-fp-params ( rep -- )\r
+ drop dummy-fp-params? [ float-regs inc ] when ;\r
+\r
+M: int-rep next-fastcall-param\r
+ int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;\r
+\r
+M: float-rep next-fastcall-param\r
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;\r
+\r
+M: double-rep next-fastcall-param\r
+ float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;\r
+\r
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )\r
+\r
+M: stack-params reg-class-full? 2drop t ;\r
+\r
+M: reg-class reg-class-full?\r
+ [ get ] swap '[ _ param-regs length ] bi >= ;\r
+\r
+: alloc-stack-param ( rep -- n reg-class rep )\r
+ stack-params get\r
+ [ rep-size cell align stack-params +@ ] dip\r
+ stack-params dup ;\r
+\r
+: alloc-fastcall-param ( rep -- n reg-class rep )\r
+ [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;\r
+\r
+:: alloc-parameter ( rep abi -- reg rep )\r
+ rep dup reg-class-of abi reg-class-full?\r
+ [ alloc-stack-param ] [ alloc-fastcall-param ] if\r
+ [ abi param-reg ] dip ;\r
+\r
+: reset-fastcall-counts ( -- )\r
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;\r
+\r
+: with-param-regs ( quot -- )\r
+ #! In quot you can call alloc-parameter\r
+ [ reset-fastcall-counts call ] with-scope ; inline\r
+\r
+:: move-parameters ( params word -- )\r
+ #! Moves values from C stack to registers (if word is\r
+ #! ##load-param-reg) and registers to C stack (if word is\r
+ #! ##save-param-reg).\r
+ 0 params alien-parameters flatten-c-types [\r
+ [ params abi>> alloc-parameter word execute( offset reg rep -- ) ]\r
+ [ rep-size cell align + ]\r
+ 2bi\r
+ ] each drop ; inline\r
+\r
+: parameter-offsets ( types -- offsets )\r
+ 0 [ stack-size + ] accumulate nip ;\r
+\r
+: prepare-parameters ( parameters -- offsets types indices )\r
+ [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;\r
+\r
+GENERIC: unbox-parameter ( src n c-type -- )\r
+\r
+M: c-type unbox-parameter\r
+ [ rep>> ] [ unboxer>> ] bi ##unbox ;\r
+\r
+M: long-long-type unbox-parameter\r
+ unboxer>> ##unbox-long-long ;\r
+\r
+M: struct-c-type unbox-parameter\r
+ [ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ]\r
+ [ base-type unbox-parameter ]\r
+ if-value-struct ;\r
+\r
+: unbox-parameters ( offset node -- )\r
+ parameters>> swap\r
+ '[\r
+ prepare-parameters\r
+ [\r
+ [ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*\r
+ unbox-parameter\r
+ ] 3each\r
+ ]\r
+ [ length neg ##inc-d ]\r
+ bi ;\r
+\r
+: prepare-box-struct ( node -- offset )\r
+ #! Return offset on C stack where to store unboxed\r
+ #! parameters. If the C function is returning a structure,\r
+ #! the first parameter is an implicit target area pointer,\r
+ #! so we need to use a different offset.\r
+ return>> large-struct?\r
+ [ ##prepare-box-struct cell ] [ 0 ] if ;\r
+\r
+: objects>registers ( params -- )\r
+ #! Generate code for unboxing a list of C types, then\r
+ #! generate code for moving these parameters to registers on\r
+ #! architectures where parameters are passed in registers.\r
+ [\r
+ [ prepare-box-struct ] keep\r
+ [ unbox-parameters ] keep\r
+ \ ##load-param-reg move-parameters\r
+ ] with-param-regs ;\r
+\r
+GENERIC: box-return ( c-type -- dst )\r
+\r
+M: c-type box-return\r
+ [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;\r
+\r
+M: long-long-type box-return\r
+ [ f ] dip boxer>> ^^box-long-long ;\r
+\r
+M: struct-c-type box-return\r
+ [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;\r
+\r
+: box-return* ( node -- )\r
+ return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;\r
+\r
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )\r
+\r
+M: string dlsym-valid? dlsym ;\r
+\r
+M: array dlsym-valid? '[ _ dlsym ] any? ;\r
+\r
+: check-dlsym ( symbols dll -- )\r
+ dup dll-valid? [\r
+ dupd dlsym-valid?\r
+ [ drop ] [ cfg get word>> no-such-symbol ] if\r
+ ] [ dll-path cfg get word>> no-such-library drop ] if ;\r
+\r
+: decorated-symbol ( params -- symbols )\r
+ [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi\r
+ {\r
+ [ drop ]\r
+ [ "@" glue ]\r
+ [ "@" glue "_" prepend ]\r
+ [ "@" glue "@" prepend ]\r
+ } 2cleave\r
+ 4array ;\r
+\r
+: alien-invoke-dlsym ( params -- symbols dll )\r
+ [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]\r
+ [ library>> load-library ]\r
+ bi 2dup check-dlsym ;\r
+\r
+: return-size ( ctype -- n )\r
+ #! Amount of space we reserve for a return value.\r
+ {\r
+ { [ dup c-struct? not ] [ drop 0 ] }\r
+ { [ dup large-struct? not ] [ drop 2 cells ] }\r
+ [ heap-size ]\r
+ } cond ;\r
+\r
+: <alien-stack-frame> ( params -- stack-frame )\r
+ stack-frame new\r
+ swap\r
+ [ return>> return-size >>return ]\r
+ [ alien-parameters [ stack-size ] map-sum >>params ] bi\r
+ t >>calls-vm? ;\r
+\r
+: alien-node-height ( params -- )\r
+ [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;\r
+\r
+: emit-alien-node ( node quot -- )\r
+ '[\r
+ make-kill-block\r
+ params>>\r
+ [ <alien-stack-frame> ##stack-frame ]\r
+ _\r
+ [ alien-node-height ]\r
+ tri\r
+ ] emit-trivial-block ; inline\r
+\r
+M: #alien-invoke emit-node\r
+ [\r
+ ! Unbox parameters\r
+ dup objects>registers\r
+ ! Call function\r
+ dup alien-invoke-dlsym ##alien-invoke\r
+ ! Box return value\r
+ dup ##cleanup\r
+ box-return*\r
+ ] emit-alien-node ;\r
+\r
+M: #alien-indirect emit-node\r
+ [\r
+ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr\r
+ {\r
+ [ drop objects>registers ]\r
+ [ nip ##alien-indirect ]\r
+ [ drop ##cleanup ]\r
+ [ drop box-return* ]\r
+ } 2cleave\r
+ ] emit-alien-node ;\r
+\r
+M: #alien-assembly emit-node\r
+ [\r
+ [ objects>registers ]\r
+ [ quot>> ##alien-assembly ]\r
+ [ box-return* ]\r
+ tri\r
+ ] emit-alien-node ;\r
+\r
+GENERIC: box-parameter ( n c-type -- dst )\r
+\r
+M: c-type box-parameter\r
+ [ rep>> ] [ boxer>> ] bi ^^box ;\r
+\r
+M: long-long-type box-parameter\r
+ boxer>> ^^box-long-long ;\r
+\r
+M: struct-c-type box-parameter\r
+ [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;\r
+\r
+: box-parameters ( params -- )\r
+ alien-parameters\r
+ [ length ##inc-d ]\r
+ [\r
+ prepare-parameters\r
+ [\r
+ next-vreg next-vreg ##save-context\r
+ base-type box-parameter swap <ds-loc> ##replace\r
+ ] 3each\r
+ ] bi ;\r
+\r
+: registers>objects ( node -- )\r
+ ! Generate code for boxing input parameters in a callback.\r
+ [\r
+ dup \ ##save-param-reg move-parameters\r
+ ##begin-callback\r
+ next-vreg next-vreg ##restore-context\r
+ box-parameters\r
+ ] with-param-regs ;\r
+\r
+: callback-return-quot ( ctype -- quot )\r
+ return>> {\r
+ { [ dup void? ] [ drop [ ] ] }\r
+ { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }\r
+ [ c-type c-type-unboxer-quot ]\r
+ } cond ;\r
+\r
+: callback-prep-quot ( params -- quot )\r
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;\r
+\r
+: wrap-callback-quot ( params -- quot )\r
+ [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append\r
+ yield-hook get\r
+ '[ _ _ do-callback ]\r
+ >quotation ;\r
+\r
+GENERIC: unbox-return ( src c-type -- )\r
+\r
+M: c-type unbox-return\r
+ [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;\r
+\r
+M: long-long-type unbox-return\r
+ [ f ] dip unboxer>> ##unbox-long-long ;\r
+\r
+M: struct-c-type unbox-return\r
+ [ ^^unbox-any-c-ptr ] dip\r
+ [ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ;\r
+\r
+M: #alien-callback emit-node\r
+ dup params>> xt>> dup\r
+ [\r
+ ##prologue\r
+ [\r
+ [ registers>objects ]\r
+ [ wrap-callback-quot ##alien-callback ]\r
+ [\r
+ alien-return [ ##end-callback ] [\r
+ [ D 0 ^^peek ] dip\r
+ ##end-callback\r
+ base-type unbox-return\r
+ ] if-void\r
+ ] tri\r
+ ] emit-alien-node\r
+ ##epilogue\r
+ ##return\r
+ ] with-cfg-builder ;\r
-! 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
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 - ;
[
[ word>> ##call ]
[ call-height adjust-d ] bi
+ make-kill-block
] emit-trivial-block ;
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
[ ] 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 ]
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
+ make-kill-block
##prologue
##branch
begin-basic-block ;
: 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 )
! #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 ;
! #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 ;
-
-: <alien-stack-frame> ( 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 <alien-stack-frame> ] 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 ;
{ instructions vector }
{ successors vector }
{ predecessors vector }
+{ kill-block? boolean }
{ unlikely? boolean } ;
: <basic-block> ( -- bb )
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 ;
: <dfa-worklist> ( cfg dfa -- queue )
block-order <hashed-dlist> [ 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
def: dst/tagged-rep
literal: val ;
+INSN: ##load-float
+def: dst/float-rep
+literal: val ;
+
INSN: ##load-double
def: dst/double-rep
literal: val ;
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
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
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
[ 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
} 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 -- )
[ 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 ] [
{
[ ]
} 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,
! 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 ;
] bi ;
: split-uses ( uses n -- before after )
- '[ n>> _ <= ] partition ;
+ [ '[ n>> _ < ] filter ]
+ [ '[ n>> _ > ] filter ]
+ 2bi ;
ERROR: splitting-too-early ;
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 ;
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 ;
{ 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
{ 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
{ 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
{ 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
{ 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 }
{ 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 }
{ 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 }
{ 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 } } }
}
}
}
{ 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
{ 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 }
{ 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 } } }
}
}
}
{ 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
{ 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 } } }
}
}
{ 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
{ 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 } } }
}
}
{ 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
{ 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 } } }
}
}
{ 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
{ 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 } } }
}
}
{ 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
{ 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 } } }
}
}
{ 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
{ 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
{ 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
{ 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 } } }
}
{ 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 } } }
}
}
{ 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 } } }
}
{ 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 } } }
}
}
{ 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
C: <live-range> live-range
-SYMBOLS: +def+ +use+ +memory+ ;
+TUPLE: vreg-use n def-rep use-rep ;
-TUPLE: vreg-use rep n type ;
-
-C: <vreg-use> vreg-use
+: <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 ;
: last-use ( live-interval -- use ) uses>> last ; inline
+: new-use ( insn# uses -- use )
+ [ <vreg-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 ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
-:: add-use ( rep n type live-interval -- )
- type +memory+ eq? [
- rep n type <vreg-use>
- live-interval uses>> push
- ] unless ;
-
: <live-interval> ( vreg reg-class -- live-interval )
\ live-interval new
V{ } clone >>uses
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 ;
-
-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 ;
+ n live-interval (add-use) vreg rep-of >>def-rep drop ;
+
+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 ] [
[ 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? ]
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 ]
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 ;
[ 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
! 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:
: 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 ;
: 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 ;
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@ >= ;
+++ /dev/null
-! 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 <reversed> ] 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 ;
+++ /dev/null
-Slava Pestov
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 [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
-[ ] [ gensym [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
-[ gensym [ <label> dup define-label %jump-label ] with-fixup ] must-fail
-[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
-[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
] tri ;
: generate ( cfg -- code )
- dup label>> [
+ [
H{ } clone labels set
linearization-order
[ number-blocks ] [ [ generate-block ] each ] bi
! Special cases
M: ##no-tco generate-insn drop ;
+M: ##stack-frame generate-insn drop ;
+
M: ##prologue generate-insn
drop
cfg get stack-frame>>
CODEGEN: ##load-integer %load-immediate
CODEGEN: ##load-tagged %load-immediate
CODEGEN: ##load-reference %load-reference
+CODEGEN: ##load-float %load-float
CODEGEN: ##load-double %load-double
CODEGEN: ##load-vector %load-vector
CODEGEN: ##peek %peek
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
+CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
CODEGEN: ##spill %spill
CODEGEN: ##reload %reload
+! Conditional branches
<<
SYNTAX: CONDITIONAL:
CONDITIONAL: ##fixnum-add %fixnum-add
CONDITIONAL: ##fixnum-sub %fixnum-sub
CONDITIONAL: ##fixnum-mul %fixnum-mul
+
+! FFI
+CODEGEN: ##box %box
+CODEGEN: ##box-long-long %box-long-long
+CODEGEN: ##box-large-struct %box-large-struct
+CODEGEN: ##box-small-struct %box-small-struct
+CODEGEN: ##unbox %unbox
+CODEGEN: ##unbox-long-long %unbox-long-long
+CODEGEN: ##unbox-large-struct %unbox-large-struct
+CODEGEN: ##unbox-small-struct %unbox-small-struct
+CODEGEN: ##prepare-box-struct %prepare-box-struct
+CODEGEN: ##load-param-reg %load-param-reg
+CODEGEN: ##alien-invoke %alien-invoke
+CODEGEN: ##cleanup %cleanup
+CODEGEN: ##alien-indirect %alien-indirect
+CODEGEN: ##save-param-reg %save-param-reg
+CODEGEN: ##begin-callback %begin-callback
+CODEGEN: ##alien-callback %alien-callback
+CODEGEN: ##end-callback %end-callback
+
+M: ##alien-assembly generate-insn quot>> call( -- ) ;
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
-: push-double ( value vector -- )
- [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
- swap set-alien-double ;
-
-! Owner
-SYMBOL: compiling-word
-
! Parameter table
SYMBOL: parameter-table
[ [ compute-relative-label ] map concat ]
bi* ;
-: init-fixup ( word -- )
- compiling-word set
+: init-fixup ( -- )
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
: align-code ( n -- )
alignment (align-code) ;
-GENERIC# emit-data 1 ( obj label -- )
-
-M: float emit-data
- 8 align-code
- resolve-label
- building get push-double ;
-
-M: byte-array emit-data
- 16 align-code
+: emit-data ( obj label -- )
+ over length align-code
resolve-label
building get push-all ;
: emit-binary-literals ( -- )
binary-literal-table get [ emit-data ] assoc-each ;
-: with-fixup ( word quot -- code )
+: with-fixup ( quot -- code )
'[
init-fixup
@
compiler.cfg
compiler.cfg.builder
+compiler.cfg.builder.alien
compiler.cfg.optimizer
compiler.cfg.finalization
-compiler.codegen
-compiler.codegen.alien ;
+compiler.codegen ;
IN: compiler
SYMBOL: compiled
{ 1 1 } [ indirect-test-1 ] must-infer-as
-[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
-
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
[ 100 ] [ "p" get ?promise ] unit-test
-! Regression: calling an undefined function would raise a protection fault
-FUNCTION: void this_does_not_exist ( ) ;
-
-[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
-
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
--- /dev/null
+USING: tools.test namespaces assocs alien.syntax kernel\r
+compiler.errors accessors alien ;\r
+FROM: alien.libraries => add-library ;\r
+IN: compiler.tests.linkage-errors\r
+\r
+! Regression: calling an undefined function would raise a protection fault\r
+FUNCTION: void this_does_not_exist ( ) ;\r
+\r
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with\r
+\r
+[ T{ no-such-symbol { name "this_does_not_exist" } } ]\r
+[ \ this_does_not_exist linkage-errors get at error>> ] unit-test\r
+\r
+<< "no_such_library" "no_such_library" cdecl add-library >>\r
+\r
+LIBRARY: no_such_library\r
+\r
+FUNCTION: void no_such_function ( ) ;\r
+\r
+[ T{ no-such-library { name "no_such_library" } } ]\r
+[ \ no_such_function linkage-errors get at error>> ] unit-test\r
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-float cpu ( reg val -- )
HOOK: %load-double cpu ( reg val -- )
HOOK: %load-vector cpu ( reg val rep -- )
M: stack-params param-reg 2drop ;
-! Does this architecture support %load-double, %load-vector and
-! objects in %compare-imm?
+! Does this architecture support %load-float, %load-double,
+! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? )
! Can this value be an immediate operand for %add-imm, %sub-imm,
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
-! Load a value (from the data stack in the ds register).
-! The value is then passed as a parameter to a VM to_*() function
-HOOK: %pop-stack cpu ( n -- )
+! Call a function to convert a tagged pointer into a value that
+! can be passed to a C function, or returned from a callback
+HOOK: %unbox cpu ( src n rep func -- )
-! Store a value (to the data stack in the VM's current context)
-! The value is passed to a VM to_*() function -- used for
-! callback returns
-HOOK: %pop-context-stack cpu ( -- )
+HOOK: %unbox-long-long cpu ( src n func -- )
-! Store a value (to the data stack in the ds register).
-! The value was returned from a VM from_*() function
-HOOK: %push-stack cpu ( -- )
+HOOK: %unbox-small-struct cpu ( src c-type -- )
-! Store a value (to the data stack in the VM's current context)
-! The value is returned from a VM from_*() function -- used for
-! callback parameters
-HOOK: %push-context-stack cpu ( -- )
-
-! Call a function to convert a tagged pointer returned by
-! %pop-stack or %pop-context-stack into a value that can be
-! passed to a C function, or returned from a callback
-HOOK: %unbox cpu ( n rep func -- )
-
-HOOK: %unbox-long-long cpu ( n func -- )
-
-HOOK: %unbox-small-struct cpu ( c-type -- )
-
-HOOK: %unbox-large-struct cpu ( n c-type -- )
+HOOK: %unbox-large-struct cpu ( src n c-type -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
-! which is then pushed on the data stack by %push-stack or
-! %push-context-stack
-HOOK: %box cpu ( n rep func -- )
+! which is then pushed on the data stack
+HOOK: %box cpu ( dst n rep func -- )
-HOOK: %box-long-long cpu ( n func -- )
+HOOK: %box-long-long cpu ( dst n func -- )
HOOK: %prepare-box-struct cpu ( -- )
-HOOK: %box-small-struct cpu ( c-type -- )
+HOOK: %box-small-struct cpu ( dst c-type -- )
-HOOK: %box-large-struct cpu ( n c-type -- )
+HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
-
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
+HOOK: %alien-indirect cpu ( src -- )
HOOK: %begin-callback cpu ( -- )
HOOK: %end-callback cpu ( -- )
-HOOK: %end-callback-value cpu ( c-type -- )
-
HOOK: stack-cleanup cpu ( params -- n )
M: object stack-cleanup drop 0 ;
M:: ppc %load-param-reg ( stack reg rep -- )
reg stack local@ rep load-from-frame ;
-M: ppc %pop-stack ( n -- )
- [ 3 ] dip <ds-loc> loc>operand LWZ ;
-
-M: ppc %push-stack ( -- )
- ds-reg ds-reg 4 ADDI
- int-regs return-reg ds-reg 0 STW ;
-
-M: ppc %push-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- 12 12 4 ADDI
- 12 11 "datastack" context-field-offset STW
- int-regs return-reg 12 0 STW ;
-
-M: ppc %pop-context-stack ( -- )
- 11 %context
- 12 11 "datastack" context-field-offset LWZ
- int-regs return-reg 12 0 LWZ
- 12 12 4 SUBI
- 12 11 "datastack" context-field-offset STW ;
-
-M: ppc %unbox ( n rep func -- )
- ! Value must be in r3
- 4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+GENERIC: load-param ( reg src -- )
+
+M: integer load-param int-rep %copy ;
+
+M: spill-slot load-param n>> spill@ LWZ ;
+
+GENERIC: store-param ( reg dst -- )
+
+M: integer store-param swap int-rep %copy ;
+
+M: spill-slot store-param n>> spill@ STW ;
-M: ppc %unbox-long-long ( n func -- )
+:: call-unbox-func ( src func -- )
+ 3 src load-param
4 %load-vm-addr
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- [
- [ [ 3 1 ] dip local@ STW ]
- [ [ 4 1 ] dip cell + local@ STW ] bi
- ] when* ;
+ func f %alien-invoke ;
-M: ppc %unbox-large-struct ( n c-type -- )
- ! Value must be in r3
- ! Compute destination address and load struct size
- [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
- 6 %load-vm-addr
- ! Call the function
- "to_value_struct" f %alien-invoke ;
+M:: ppc %unbox ( src n rep func -- )
+ src func call-unbox-func
+ ! Store the return value on the C stack
+ n [ rep reg-class-of return-reg rep %save-param-reg ] when* ;
-M:: ppc %box ( n rep func -- )
- ! If the source is a stack location, load it into freg #0.
- ! If the source is f, then we assume the value is already in
- ! freg #0.
+M:: ppc %unbox-long-long ( src n func -- )
+ src func call-unbox-func
+ ! Store the return value on the C stack
+ n [
+ 3 1 n local@ STW
+ 4 1 n cell + local@ STW
+ ] when ;
+
+M:: ppc %unbox-large-struct ( src n c-type -- )
+ 4 src load-param
+ 3 1 n local@ ADDI
+ heap-size 5 LI
+ "memcpy" "libc" load-library %alien-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 %alien-invoke
+ 3 dst store-param ;
-M: ppc %box-long-long ( n func -- )
- [
- [
- [ [ 3 1 ] dip local@ LWZ ]
- [ [ 4 1 ] dip cell + local@ LWZ ] bi
- ] when*
- 5 %load-vm-addr
- ] dip f %alien-invoke ;
+M:: ppc %box-long-long ( dst n func -- )
+ n [
+ 3 1 n local@ LWZ
+ 4 1 n cell + local@ LWZ
+ ] when
+ func f %alien-invoke
+ 3 dst store-param ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
-M: ppc %box-large-struct ( n c-type -- )
+M:: ppc %box-large-struct ( dst n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
- [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+ 3 1 n struct-return@ ADDI
+ c-type heap-size 4 LI
5 %load-vm-addr
! Call the function
- "from_value_struct" f %alien-invoke ;
+ "from_value_struct" f %alien-invoke
+ 3 dst store-param ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 %context
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-M: ppc %prepare-alien-indirect ( -- )
- 3 ds-reg 0 LWZ
- ds-reg ds-reg 4 SUBI
- 4 %load-vm-addr
- "pinned_alien_offset" f %alien-invoke
- 16 3 MR ;
-
-M: ppc %alien-indirect ( -- )
- 16 MTLR BLRL ;
+M: ppc %alien-indirect ( src -- )
+ [ 11 ] dip load-param 11 MTLR BLRL ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
-M: ppc %box-small-struct ( c-type -- )
+M:: ppc %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
- heap-size 7 LI
+ c-type heap-size 7 LI
8 %load-vm-addr
- "from_medium_struct" f %alien-invoke ;
+ "from_medium_struct" f %alien-invoke
+ 3 dst store-param ;
: %unbox-struct-1 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
3 3 0 LWZ ;
: %unbox-struct-2 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
4 3 4 LWZ
3 3 0 LWZ ;
: %unbox-struct-4 ( -- )
! Alien must be in r3.
- 4 %load-vm-addr
- "alien_offset" f %alien-invoke
6 3 12 LWZ
5 3 8 LWZ
4 3 4 LWZ
3 3 0 LWZ ;
+M:: ppc %unbox-small-struct ( src c-type -- )
+ src 3 load-param
+ c-type heap-size {
+ { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
+ { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
+ { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
+ } cond ;
+
M: ppc %begin-callback ( -- )
3 %load-vm-addr
"begin_callback" f %alien-invoke ;
M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
3 swap %load-reference
4 3 quot-entry-point-offset LWZ
4 MTLR
- BLRL
- 3 4 %save-context ;
+ BLRL ;
M: ppc %end-callback ( -- )
3 %load-vm-addr
"end_callback" f %alien-invoke ;
-M: ppc %end-callback-value ( ctype -- )
- ! Save top of data stack
- 16 ds-reg 0 LWZ
- %end-callback
- ! Restore top of data stack
- 3 16 MR
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: ppc %unbox-small-struct ( size -- )
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- { 4 [ %unbox-struct-4 ] }
- } case ;
-
enable-float-functions
USE: vocabs.loader
vocabs.loader accessors init classes.struct combinators
command-line make words compiler compiler.units
compiler.constants compiler.alien compiler.codegen
-compiler.codegen.alien compiler.codegen.fixup
-compiler.cfg.instructions compiler.cfg.builder
+compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.builder.alien
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture vm ;
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
-M: x86.32 %load-double ( dst val -- )
- [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
-
M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
+M: x86.32 %load-float ( dst val -- )
+ <float> float-rep %load-vector ;
+
+M: x86.32 %load-double ( dst val -- )
+ <double> double-rep %load-vector ;
+
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
-M:: x86.32 %box ( n rep func -- )
+M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
- func f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- )
[
- EDX over next-stack@ MOV
- EAX swap cell - next-stack@ MOV
+ [ EDX swap next-stack@ MOV ]
+ [ EAX swap cell - next-stack@ MOV ] bi
] when* ;
-M: x86.32 %box-long-long ( n func -- )
- [ (%box-long-long) ] dip
+M:: x86.32 %box-long-long ( dst n func -- )
+ n (%box-long-long)
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
- f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M:: x86.32 %box-large-struct ( n c-type -- )
+M:: x86.32 %box-large-struct ( dst n c-type -- )
EDX n struct-return@ LEA
8 save-vm-ptr
4 stack@ c-type heap-size MOV
0 stack@ EDX MOV
- "from_value_struct" f %alien-invoke ;
+ "from_value_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
! Store it as the first parameter
0 local@ EAX MOV ;
-M: x86.32 %box-small-struct ( c-type -- )
+M:: x86.32 %box-small-struct ( dst c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 save-vm-ptr
- 8 stack@ swap heap-size MOV
+ 8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
- "from_small_struct" f %alien-invoke ;
-
-M: x86.32 %pop-stack ( n -- )
- EAX swap ds-reg reg-stack MOV ;
+ "from_small_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M: x86.32 %pop-context-stack ( -- )
- temp-reg %context
- EAX temp-reg "datastack" context-field-offset [+] MOV
- EAX EAX [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
-
-: call-unbox-func ( func -- )
+:: call-unbox-func ( src func -- )
+ EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
- f %alien-invoke ;
-
-M: x86.32 %unbox ( n rep func -- )
- #! The value being unboxed must already be in EAX.
- #! If n is f, we're unboxing a return value about to be
- #! returned by the callback. Otherwise, we're unboxing
- #! a parameter to a C function about to be called.
- call-unbox-func
+ func f %alien-invoke ;
+
+M:: x86.32 %unbox ( src n rep func -- )
+ ! If n is f, we're unboxing a return value about to be
+ ! returned by the callback. Otherwise, we're unboxing
+ ! a parameter to a C function about to be called.
+ src func call-unbox-func
! Store the return value on the C stack
- over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
+ n [ n local@ rep store-return-reg ] when ;
-M: x86.32 %unbox-long-long ( n func -- )
- call-unbox-func
+M:: x86.32 %unbox-long-long ( src n func -- )
+ src func call-unbox-func
! Store the return value on the C stack
- [
+ n [
[ local@ EAX MOV ]
[ 4 + local@ EDX MOV ] bi
] when* ;
-: %unbox-struct-1 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV ;
-
-: %unbox-struct-2 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV ;
-
-M: x86 %unbox-small-struct ( size -- )
- #! Alien must be in EAX.
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- } case ;
+M: x86 %unbox-small-struct ( src size -- )
+ [ [ EAX ] dip int-rep %copy ]
+ [
+ heap-size 4 > [ EDX EAX 4 [+] MOV ] when
+ EAX EAX [] MOV
+ ] bi* ;
-M:: x86.32 %unbox-large-struct ( n c-type -- )
- ! Alien must be in EAX.
- ! Compute destination address
+M:: x86.32 %unbox-large-struct ( src n c-type -- )
+ EAX src int-rep %copy
EDX n local@ LEA
- 12 save-vm-ptr
8 stack@ c-type heap-size MOV
- 4 stack@ EDX MOV
- 0 stack@ EAX MOV
- "to_value_struct" f %alien-invoke ;
-
-M: x86.32 %prepare-alien-indirect ( -- )
- EAX ds-reg [] MOV
- ds-reg 4 SUB
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "pinned_alien_offset" f %alien-invoke
- EBP EAX MOV ;
+ 4 stack@ EAX MOV
+ 0 stack@ EDX MOV
+ "memcpy" "libc" load-library %alien-invoke ;
-M: x86.32 %alien-indirect ( -- )
- EBP CALL ;
+M: x86.32 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
- ESP 4 [+] 0 MOV
+ 4 stack@ 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
- EAX EDX %restore-context
- EAX swap %load-reference
- EAX quot-entry-point-offset [+] CALL
- EAX EDX %save-context ;
+ [ EAX ] dip %load-reference
+ EAX quot-entry-point-offset [+] CALL ;
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.32 %end-callback-value ( ctype -- )
- %pop-context-stack
- 4 stack@ EAX MOV
- %end-callback
- ! Place former top of data stack back in EAX
- EAX 4 stack@ MOV
- ! Unbox EAX
- unbox-return ;
-
GENERIC: float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
-M: x86.64 %load-double ( dst val -- )
- [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
-
M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
+M: x86.64 %load-float ( dst val -- )
+ <float> float-rep %load-vector ;
+
+M: x86.64 %load-double ( dst val -- )
+ <double> double-rep %load-vector ;
+
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
call
] with-scope ; inline
-M: x86.64 %pop-stack ( n -- )
- param-reg-0 swap ds-reg reg-stack MOV ;
-
-M: x86.64 %pop-context-stack ( -- )
- temp-reg %context
- param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
- param-reg-0 param-reg-0 [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
-
-M:: x86.64 %unbox ( n rep func -- )
+M:: x86.64 %unbox ( src n rep func -- )
+ param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
! Call the unboxer
func f %alien-invoke
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
: %unbox-struct-field ( rep i -- )
- ! Alien must be in param-reg-0.
R11 swap cells [+] swap reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
-M: x86.64 %unbox-small-struct ( c-type -- )
- ! Alien must be in param-reg-0.
- param-reg-1 %mov-vm-ptr
- "alien_offset" f %alien-invoke
- ! Move alien_offset() return value to R11 so that we don't
- ! clobber it.
- R11 RAX MOV
+M:: x86.64 %unbox-small-struct ( src c-type -- )
+ ! Move src to R11 so that we don't clobber it.
+ R11 src int-rep %copy
[
- flatten-struct-type [ %unbox-struct-field ] each-index
+ c-type flatten-struct-type
+ [ %unbox-struct-field ] each-index
] with-return-regs ;
-M:: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in param-reg-0
- ! Load destination address into param-reg-1
- param-reg-1 n param@ LEA
- ! Load structure size into param-reg-2
+M:: x86.64 %unbox-large-struct ( src n c-type -- )
+ param-reg-1 src int-rep %copy
+ param-reg-0 n param@ LEA
param-reg-2 c-type heap-size MOV
- param-reg-3 %mov-vm-ptr
- ! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
+ "memcpy" "libc" load-library %alien-invoke ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of cdecl param-reg ]
[ ]
tri %copy ;
-M:: x86.64 %box ( n rep func -- )
+M:: x86.64 %box ( dst n rep func -- )
n [
n
0 rep reg-class-of cdecl param-reg
rep load-return-value
] if
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f %alien-invoke ;
+ func f %alien-invoke
+ dst RAX tagged-rep %copy ;
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
-M: x86.64 %box-small-struct ( c-type -- )
+M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
[
- [ flatten-struct-type [ %box-struct-field ] each-index ]
- [ param-reg-2 swap heap-size MOV ] bi
+ c-type flatten-struct-type [ %box-struct-field ] each-index
+ param-reg-2 c-type heap-size MOV
param-reg-0 0 box-struct-field@ MOV
param-reg-1 1 box-struct-field@ MOV
param-reg-3 %mov-vm-ptr
"from_small_struct" f %alien-invoke
+ dst RAX tagged-rep %copy
] with-return-regs ;
: struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
-M: x86.64 %box-large-struct ( n c-type -- )
+M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
- param-reg-1 swap heap-size MOV
+ param-reg-1 c-type heap-size MOV
! Compute destination address
- param-reg-0 swap struct-return@ LEA
+ param-reg-0 n struct-return@ LEA
param-reg-2 %mov-vm-ptr
! Copy the struct from the C stack
- "from_value_struct" f %alien-invoke ;
+ "from_value_struct" f %alien-invoke
+ dst RAX tagged-rep %copy ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
! Store it as the first parameter
0 param@ RAX MOV ;
-M: x86.64 %prepare-var-args RAX RAX XOR ;
-
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %prepare-alien-indirect ( -- )
- param-reg-0 ds-reg [] MOV
- ds-reg 8 SUB
- param-reg-1 %mov-vm-ptr
- "pinned_alien_offset" f %alien-invoke
- nv-reg RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
- nv-reg CALL ;
+M: x86.64 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
"begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
- param-reg-0 param-reg-1 %restore-context
- param-reg-0 swap %load-reference
- param-reg-0 quot-entry-point-offset [+] CALL
- param-reg-0 param-reg-1 %save-context ;
+ [ param-reg-0 ] dip %load-reference
+ param-reg-0 quot-entry-point-offset [+] CALL ;
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.64 %end-callback-value ( ctype -- )
- %pop-context-stack
- nv-reg param-reg-0 MOV
- %end-callback
- param-reg-0 nv-reg MOV
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
USING: accessors arrays sequences math splitting make assocs
kernel layouts system alien.c-types classes.struct
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
-cpu.x86 compiler.codegen.alien compiler.cfg.registers ;
+cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs
M: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
+: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
+
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
- [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
+ [ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
-M: x86 %push-stack ( -- )
- ds-reg cell ADD
- ds-reg [] int-regs return-reg MOV ;
-
-M: x86 %push-context-stack ( -- )
- temp-reg %context
- temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
- temp-reg temp-reg "datastack" context-field-offset [+] MOV
- temp-reg [] int-regs return-reg MOV ;
-
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: (%boolean) ( dst temp insn -- )
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
-: infer-params ( params -- )
- param-prep-quot infer-quot-here ;
-
: alien-stack ( params extra -- )
over parameters>> length + consume-d >>in-d
dup return>> void? 0 1 ? produce-d >>out-d
! Set ABI
dup library>> library-abi >>abi
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
pop-abi
pop-params
pop-return
- ! Quotation which coerces parameters to required types
- 1 infer->r
- dup infer-params
- 1 infer-r>
+ ! Coerce parameters to required types
+ dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
pop-params
pop-return
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
swap [ push ] [ remove! drop ] if ;
: mouse-scroll ( wParam -- array )
- >lo-hi [ -120 /f ] map ;
+ >lo-hi [ -80 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
{ "selector" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
-HELP: 2reverse-each
-{ $values
- { "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
-{ $description "Reverse the sequences using the " { $link <reversed> } " word and calls " { $link 2each } " on the reversed sequences." }
-{ $examples { $example "USING: sequences math prettyprint ;"
- "{ 10 20 30 } { 1 2 3 } [ + . ] 2reverse-each"
- "33\n22\n11"
-} } ;
-
HELP: 2unclip-slice
{ $values
{ "seq1" sequence } { "seq2" sequence }
: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
-: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
- [ [ <reversed> ] bi@ ] dip 2each ; inline
-
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
: cfg-vertex, ( bb -- )
[ number>> number>string ]
- [ kill-block? { "color=grey" "style=filled" } { } ? ]
+ [ kill-block?>> { "color=grey" "style=filled" } { } ? ]
bi node-style, ;
: cfgs ( cfgs -- )
return parent->alien_offset(obj);
}
-/* For FFI calls passing structs by value. Cannot allocate */
-void factor_vm::to_value_struct(cell src, void *dest, cell size)
-{
- memcpy(dest,alien_offset(src),size);
-}
-
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
-{
- return parent->to_value_struct(src,dest,size);
-}
-
/* For FFI callbacks receiving structs by value */
cell factor_vm::from_value_struct(void *src, cell size)
{
VM_C_API char *alien_offset(cell object, factor_vm *vm);
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
VM_C_API cell allot_alien(void *address, factor_vm *vm);
-VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *vm);
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *vm);
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *vm);
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *vm);
void primitive_dlclose();
void primitive_dll_validp();
char *alien_offset(cell obj);
- void to_value_struct(cell src, void *dest, cell size);
cell from_value_struct(void *src, cell size);
cell from_small_struct(cell x, cell y, cell size);
cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
projects / factor.git / commitdiff