M: struct-c-type c-type ;
-: if-value-struct ( ctype true false -- )
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-: if-small-struct ( c-type true false -- ? )
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
M: struct-c-type base-type ;
M: struct-c-type stack-size
- [ heap-size cell align ] [ stack-size ] if-value-struct ;
+ dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
HOOK: flatten-struct-type cpu ( type -- reps )
: alien-parameters ( params -- seq )
dup parameters>>
- swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
-
-: alien-return ( params -- type )
- return>> dup large-struct? [ drop void ] when ;
+ swap return>> large-struct?
+ [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;
! 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
+combinators fry make 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
+compiler.cfg.builder compiler.cfg.builder.alien.params\r
+compiler.cfg.builder.blocks compiler.cfg.instructions\r
+compiler.cfg.stack-frame compiler.cfg.stacks\r
+compiler.cfg.registers 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
+! output is triples with shape { vreg rep on-stack? }\r
+GENERIC: unbox ( src c-type -- vregs )\r
\r
-: ?dummy-stack-params ( rep -- )\r
- dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;\r
+M: c-type unbox\r
+ [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi\r
+ f 3array 1array ;\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
+M: long-long-type unbox\r
+ unboxer>> int-rep ^^unbox\r
+ 0 cell\r
+ [\r
+ int-rep f ^^load-memory-imm\r
+ int-rep long-long-on-stack? 3array\r
+ ] bi-curry@ bi 2array ;\r
\r
-GENERIC: unbox-parameter ( src n c-type -- )\r
+GENERIC: unbox-parameter ( src c-type -- vregs )\r
\r
-M: c-type unbox-parameter\r
- [ rep>> ] [ unboxer>> ] bi ##unbox ;\r
+M: c-type unbox-parameter unbox ;\r
\r
-M: long-long-type unbox-parameter\r
- unboxer>> ##unbox-long-long ;\r
+M: long-long-type unbox-parameter unbox ;\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
+M:: struct-c-type unbox-parameter ( src c-type -- )\r
+ src ^^unbox-any-c-ptr :> src\r
+ c-type value-struct? [\r
+ c-type flatten-struct-type\r
+ [| rep i |\r
+ src i cells rep f ^^load-memory-imm\r
+ rep struct-on-stack? 3array\r
+ ] map-index\r
+ ] [ { { src int-rep f } } ] if ;\r
\r
-: unbox-parameters ( offset node -- )\r
- parameters>> swap\r
- '[\r
- prepare-parameters\r
+: unbox-parameters ( parameters -- vregs )\r
+ [\r
+ [ length iota <reversed> ] keep\r
[\r
- [ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*\r
+ [ <ds-loc> ^^peek ] [ base-type ] bi*\r
unbox-parameter\r
- ] 3each\r
+ ] 2map concat\r
]\r
- [ length neg ##inc-d ]\r
- bi ;\r
+ [ length neg ##inc-d ] bi ;\r
\r
-: prepare-box-struct ( node -- offset )\r
+: prepare-struct-area ( vregs return -- vregs )\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
+ large-struct? [\r
+ ^^prepare-struct-area int-rep struct-return-on-stack?\r
+ 3array prefix\r
+ ] when ;\r
+\r
+: (objects>registers) ( vregs -- )\r
+ ! Place instructions in reverse order, so that the\r
+ ! ##store-stack-param instructions come first. This is\r
+ ! because they are not clobber-insns and so we avoid some\r
+ ! spills that way.\r
+ [\r
+ first3 [ dup reg-class-of reg-class-full? ] dip or\r
+ [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]\r
+ [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]\r
+ if\r
+ ] map reverse % ;\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
+ [ abi>> ] [ parameters>> ] [ return>> ] tri\r
+ '[ \r
+ _ unbox-parameters\r
+ _ prepare-struct-area\r
+ (objects>registers)\r
] with-param-regs ;\r
\r
GENERIC: box-return ( c-type -- dst )\r
M: long-long-type box-return\r
[ f ] dip boxer>> ^^box-long-long ;\r
\r
+: if-small-struct ( c-type true false -- ? )\r
+ [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline\r
+\r
M: struct-c-type box-return\r
[ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;\r
\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
+ {\r
+ [ objects>registers ]\r
+ [ alien-invoke-dlsym ##alien-invoke ]\r
+ [ stack-cleanup ##cleanup ]\r
+ [ box-return* ]\r
+ } cleave\r
] emit-alien-node ;\r
\r
M: #alien-indirect emit-node\r
{\r
[ drop objects>registers ]\r
[ nip ##alien-indirect ]\r
- [ drop ##cleanup ]\r
+ [ drop stack-cleanup ##cleanup ]\r
[ drop box-return* ]\r
} 2cleave\r
] emit-alien-node ;\r
M: long-long-type box-parameter\r
boxer>> ^^box-long-long ;\r
\r
+: if-value-struct ( ctype true false -- )\r
+ [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline\r
+\r
M: struct-c-type box-parameter\r
[ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;\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
: box-parameters ( params -- )\r
alien-parameters\r
[ length ##inc-d ]\r
] 3each\r
] bi ;\r
\r
-: registers>objects ( node -- )\r
+:: alloc-parameter ( rep -- reg rep )\r
+ rep dup reg-class-of reg-class-full?\r
+ [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;\r
+\r
+: (registers>objects) ( params -- )\r
+ [ 0 ] dip alien-parameters flatten-c-types [\r
+ [ alloc-parameter ##save-param-reg ]\r
+ [ rep-size cell align + ]\r
+ 2bi\r
+ ] each drop ; inline\r
+\r
+: registers>objects ( params -- )\r
! Generate code for boxing input parameters in a callback.\r
- [\r
- dup \ ##save-param-reg move-parameters\r
+ dup abi>> [\r
+ dup (registers>objects)\r
##begin-callback\r
next-vreg next-vreg ##restore-context\r
box-parameters\r
GENERIC: unbox-return ( src c-type -- )\r
\r
M: c-type unbox-return\r
- [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;\r
+ unbox first first2 ##store-return ;\r
\r
M: long-long-type unbox-return\r
- [ f ] dip unboxer>> ##unbox-long-long ;\r
+ unbox first2 [ first ] bi@ ##store-long-long-return ;\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
+ [ ^^unbox-any-c-ptr ] dip ##store-struct-return ;\r
\r
M: #alien-callback emit-node\r
dup params>> xt>> dup\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
+ return>> {\r
+ { [ dup void eq? ] [ drop ##end-callback ] }\r
+ { [ dup large-struct? ] [ drop ##end-callback ] }\r
+ [\r
+ [ D 0 ^^peek ] dip\r
+ ##end-callback\r
+ base-type unbox-return\r
+ ]\r
+ } cond\r
] tri\r
] emit-alien-node\r
##epilogue\r
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.architecture fry kernel layouts math math.order
+namespaces sequences vectors ;
+IN: compiler.cfg.builder.alien.params
+
+: alloc-stack-param ( rep -- n )
+ stack-params get
+ [ rep-size cell align stack-params +@ ] dip ;
+
+: ?dummy-stack-params ( rep -- )
+ dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+ dummy-int-params? [
+ rep-size cell /i 1 max
+ [ int-regs get [ pop* ] unless-empty ] times
+ ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+ drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
+
+GENERIC: next-reg-param ( rep -- reg )
+
+M: int-rep next-reg-param
+ [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ;
+
+M: float-rep next-reg-param
+ [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
+
+M: double-rep next-reg-param
+ [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
+
+GENERIC: reg-class-full? ( reg-class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: reg-class reg-class-full? get empty? ;
+
+: init-reg-class ( abi reg-class -- )
+ [ swap param-regs <reversed> >vector ] keep set ;
+
+: with-param-regs ( abi quot -- )
+ '[
+ [ int-regs init-reg-class ]
+ [ float-regs init-reg-class ] bi
+ 0 stack-params set
+ @
+ ] with-scope ; inline
INSN: ##stack-frame
literal: stack-frame ;
+INSN: ##unbox
+def: dst
+use: src/tagged-rep
+literal: unboxer rep ;
+
+INSN: ##store-reg-param
+use: src
+literal: reg rep ;
+
+INSN: ##store-stack-param
+use: src
+literal: n rep ;
+
+INSN: ##store-return
+use: src
+literal: rep ;
+
+INSN: ##store-struct-return
+use: src/int-rep
+literal: c-type ;
+
+INSN: ##store-long-long-return
+use: src1/int-rep src2/int-rep ;
+
+INSN: ##prepare-struct-area
+def: dst/int-rep ;
+
INSN: ##box
def: dst/tagged-rep
literal: n rep boxer ;
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: symbols dll ;
INSN: ##cleanup
-literal: params ;
+literal: n ;
INSN: ##alien-indirect
use: src/int-rep ;
##box-small-struct
##box-large-struct
##unbox
-##unbox-long-long
-##unbox-large-struct
-##unbox-small-struct
-##prepare-box-struct
-##load-param-reg
+##store-reg-param
+##store-return
+##store-struct-return
+##store-long-long-return
##alien-invoke
##alien-indirect
##alien-assembly
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences fry math
-math.order combinators arrays sorting compiler.utilities locals
+USING: accessors assocs binary-search combinators
+combinators.short-circuit heaps kernel namespaces
+sequences fry locals math math.order arrays sorting
+compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
[ drop assign-blocked-register ]
} cond ;
-: spill-at-sync-point ( live-interval n -- ? )
+: spill-at-sync-point ( n live-interval -- ? )
! 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 ;
+ 2dup find-use
+ { [ ] [ def-rep>> ] } 1&&
+ [ 2drop t ] [ swap spill f ] if ;
: handle-sync-point ( n -- )
- [ active-intervals get values ] dip
- '[ [ _ spill-at-sync-point ] filter! drop ] each ;
+ active-intervals get values
+ [ [ spill-at-sync-point ] with filter! drop ] with each ;
:: handle-progress ( n sync? -- )
n {
} cond ;
: (allocate-registers) ( -- )
- ! If a live interval begins at the same location as a sync point,
- ! process the sync point before the live interval. This ensures that the
- ! return value of C function calls doesn't get spilled and reloaded
- ! unnecessarily.
- unhandled-sync-points get unhandled-intervals get smallest-heap
+ unhandled-intervals get unhandled-sync-points get smallest-heap
dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
: check-split ( live-interval n -- )
check-allocation? get [
[ [ start>> ] dip > [ splitting-too-early ] when ]
- [ [ end>> ] dip <= [ splitting-too-late ] when ]
+ [ [ end>> ] dip < [ splitting-too-late ] when ]
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
2tri
] [ 2drop ] if ; inline
{ vreg 3 }
{ reg-class float-regs }
{ start 0 }
+ { end 2 }
+ { 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 8 } }
+ { spill-rep float-rep }
+ }
+ f
+] [
+ T{ live-interval
+ { vreg 3 }
+ { reg-class float-regs }
+ { start 0 }
+ { end 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 } } }
+ } 5 split-for-spill
+] unit-test
+
+[
+ 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 8 } }
+ { spill-to T{ spill-slot f 12 } }
{ spill-rep float-rep }
}
T{ live-interval
- { vreg 3 }
+ { vreg 4 }
{ reg-class float-regs }
{ start 20 }
{ end 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-from T{ spill-slot f 12 } }
{ reload-rep float-rep }
}
] [
T{ live-interval
- { vreg 3 }
+ { vreg 4 }
{ reg-class float-regs }
{ start 0 }
{ end 30 }
! Don't insert reload if first usage is a def
[
T{ live-interval
- { vreg 4 }
+ { vreg 5 }
{ 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-to T{ spill-slot f 16 } }
{ spill-rep float-rep }
}
T{ live-interval
- { vreg 4 }
+ { vreg 5 }
{ reg-class float-regs }
{ start 20 }
{ end 30 }
}
] [
T{ live-interval
- { vreg 4 }
+ { vreg 5 }
{ reg-class float-regs }
{ start 0 }
{ end 30 }
! Multiple representations
[
T{ live-interval
- { vreg 5 }
+ { vreg 6 }
{ 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-to T{ spill-slot f 24 } }
{ spill-rep double-rep }
}
T{ live-interval
- { vreg 5 }
+ { vreg 6 }
{ 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-from T{ spill-slot f 24 } }
{ reload-rep double-rep }
}
] [
T{ live-interval
- { vreg 5 }
+ { vreg 6 }
{ reg-class float-regs }
{ start 0 }
{ end 20 }
covers?
] if ;
+:: find-use ( insn# live-interval -- vreg-use )
+ insn# live-interval uses>> [ n>> <=> ] with search nip
+ dup [ dup n>> insn# = [ drop f ] unless ] when ;
+
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
CONDITIONAL: ##fixnum-mul %fixnum-mul
! FFI
+CODEGEN: ##unbox %unbox
+CODEGEN: ##store-reg-param %store-reg-param
+CODEGEN: ##store-stack-param %store-stack-param
+CODEGEN: ##store-return %store-return
+CODEGEN: ##store-struct-return %store-struct-return
+CODEGEN: ##store-long-long-return %store-long-long-return
+CODEGEN: ##prepare-struct-area %prepare-struct-area
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: ##save-param-reg %save-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
: immediate-shift-count? ( n -- ? )
0 cell-bits 1 - between? ;
-! What c-type describes the implicit struct return pointer for
-! large structs?
-HOOK: struct-return-pointer-type cpu ( -- c-type )
-
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
+! If t, long longs are never passed in param regs
+HOOK: long-long-on-stack? cpu ( -- ? )
+
+! If t, structs are never passed in param regs
+HOOK: struct-on-stack? cpu ( -- ? )
+
+! If t, the struct return pointer is never passed in a param reg
+HOOK: struct-return-on-stack? cpu ( -- ? )
+
! 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 -- )
+HOOK: %unbox cpu ( dst src func rep -- )
+
+HOOK: %store-reg-param cpu ( src reg rep -- )
-HOOK: %unbox-long-long cpu ( src n func -- )
+HOOK: %store-stack-param cpu ( src n rep -- )
-HOOK: %unbox-small-struct cpu ( src c-type -- )
+HOOK: %store-return cpu ( src rep -- )
-HOOK: %unbox-large-struct cpu ( src n c-type -- )
+HOOK: %store-struct-return cpu ( src reps -- )
+
+HOOK: %store-long-long-return cpu ( src1 src2 -- )
+
+HOOK: %prepare-struct-area cpu ( dst -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
HOOK: %box-long-long cpu ( dst n func -- )
-HOOK: %prepare-box-struct cpu ( -- )
-
HOOK: %box-small-struct cpu ( dst c-type -- )
HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
-HOOK: %load-param-reg cpu ( stack reg rep -- )
-
HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup cpu ( params -- )
+HOOK: %cleanup cpu ( n -- )
-M: object %cleanup ( params -- ) drop ;
+M: object %cleanup ( n -- ) drop ;
HOOK: %alien-indirect cpu ( src -- )
M: ppc immediate-store? drop f ;
-M: ppc struct-return-pointer-type void* ;
-
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
os { linux netbsd solaris } member? not
and or ;
-: struct-return@ ( n -- operand )
- [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
-
-! On x86, parameters are usually never passed in registers, except with Microsoft's
-! "thiscall" and "fastcall" abis
+! On x86, parameters are usually never passed in registers,
+! except with Microsoft's "thiscall" and "fastcall" abis
M: int-regs return-reg drop EAX ;
M: float-regs param-regs 2drop { } ;
M: int-regs param-regs
nip {
- { thiscall [ { ECX } ] }
+ { thiscall [ { ECX } ] }
{ fastcall [ { ECX EDX } ] }
[ drop { } ]
} case ;
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+:: call-unbox-func ( src func -- )
+ EAX src tagged-rep %copy
+ 4 save-vm-ptr
+ 0 stack@ EAX MOV
+ func f %alien-invoke ;
+
+M:: x86.32 %unbox ( dst src func rep -- )
+ src func call-unbox-func
+ dst rep reg-class-of return-reg rep %copy ;
+
+M:: x86.32 %store-long-long-return ( src1 src2 n func -- )
+ src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
+ EAX src1 int-rep %copy
+ EDX src2 int-rep %copy ;
+
+M:: x86.32 %store-struct-return ( src c-type -- )
+ EAX src int-rep %copy
+ EDX EAX 4 [+] MOV
+ EAX EAX [] MOV ;
+
M: stack-params copy-register*
drop
{
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
-M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
-
: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
func f %alien-invoke
dst EAX tagged-rep %copy ;
+M: x86.32 struct-return@ ( n -- operand )
+ [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
+
M:: x86.32 %box-large-struct ( dst n c-type -- )
EDX n struct-return@ LEA
8 save-vm-ptr
"from_value_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
-M: x86.32 %prepare-box-struct ( -- )
- ! Compute target address for value struct return
- EAX f struct-return@ LEA
- ! Store it as the first parameter
- 0 local@ EAX MOV ;
-
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
"from_small_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
-:: call-unbox-func ( src func -- )
- EAX src tagged-rep %copy
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- 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
- n [ n local@ rep store-return-reg ] when ;
-
-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* ;
-
-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 ( src n c-type -- )
- EAX src int-rep %copy
- EDX n local@ LEA
- 8 stack@ c-type heap-size MOV
- 4 stack@ EAX MOV
- 0 stack@ EDX MOV
- "memcpy" "libc" load-library %alien-invoke ;
-
-M: x86.32 %alien-indirect ( src -- )
- ?spill-slot CALL ;
-
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
4 stack@ 0 MOV
: funny-large-struct-return? ( params -- ? )
#! MINGW ABI incompatibility disaster
[ return>> large-struct? ]
- [ abi>> mingw = os windows? not or ]
+ [ abi>> mingw eq? os windows? not or ]
bi and ;
: stack-arg-size ( params -- n )
[ drop 0 ]
} cond ;
-M: x86.32 %cleanup ( params -- )
- stack-cleanup [ ESP swap SUB ] unless-zero ;
+M: x86.32 %cleanup ( n -- )
+ [ ESP swap SUB ] unless-zero ;
M:: x86.32 %call-gc ( gc-roots -- )
4 save-vm-ptr
M: x86.32 dummy-fp-params? f ;
-! Dreadful
-M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
-M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
-M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ;
+M: x86.32 long-long-on-stack? t ;
+
+M: x86.32 structs-on-stack? t ;
-M: x86.32 struct-return-pointer-type
- os linux? void* (stack-value) ? ;
+M: x86.32 struct-return-on-stack? os linux? not ;
check-sse
[ (align-code) ]
bi ;
-M: stack-params copy-register*
- drop
- {
- { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
- { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
- } cond ;
-
-M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
-
-M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
+M:: x86.64 %unbox ( dst src func rep -- )
+ param-reg-0 src tagged-rep %copy
+ param-reg-1 %mov-vm-ptr
+ func f %alien-invoke
+ dst rep reg-class-of return-reg rep %copy ;
: with-return-regs ( quot -- )
[
call
] with-scope ; inline
-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
- ! Store the return value on the C stack if this is an
- ! alien-invoke, otherwise leave it the return register if
- ! this is the end of alien-callback
- n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
-
: %unbox-struct-field ( rep i -- )
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 ( src c-type -- )
+M:: x86.64 %store-struct-return ( src c-type -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
[
[ %unbox-struct-field ] each-index
] with-return-regs ;
-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
- "memcpy" "libc" load-library %alien-invoke ;
+M: stack-params copy-register*
+ drop
+ {
+ { [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
+ { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
+ } cond ;
-: load-return-value ( rep -- )
- [ [ 0 ] dip reg-class-of cdecl param-reg ]
- [ reg-class-of return-reg ]
- [ ]
- tri %copy ;
+M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
M:: x86.64 %box ( dst n rep func -- )
- n [
- n
- 0 rep reg-class-of cdecl param-reg
- rep %load-param-reg
- ] [
- rep load-return-value
- ] if
+ 0 rep reg-class-of cdecl param-reg
+ n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke
dst RAX tagged-rep %copy ;
dst RAX tagged-rep %copy
] with-return-regs ;
-: struct-return@ ( n -- operand )
+M: x86.64 struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
M:: x86.64 %box-large-struct ( dst n c-type -- )
"from_value_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
-M: x86.64 %prepare-box-struct ( -- )
- ! Compute target address for value struct return
- RAX f struct-return@ LEA
- ! Store it as the first parameter
- 0 param@ RAX MOV ;
-
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %alien-indirect ( src -- )
- ?spill-slot CALL ;
-
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
param-reg-1 %mov-vm-ptr
"inline_gc" f %alien-invoke ;
-M: x86.64 struct-return-pointer-type void* ;
+M: x86.64 long-long-on-stack? f ;
+
+M: x86.64 struct-on-stack? f ;
+
+M: x86.64 struct-return-on-stack? f ;
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
} case ;
M: x86 %vector>scalar %copy ;
+
M: x86 %scalar>vector %copy ;
-M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
-M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
+M:: x86 %spill ( src rep dst -- )
+ dst src rep %copy ;
+
+M:: x86 %reload ( dst rep src -- )
+ dst src rep %copy ;
+
+M:: x86 %store-reg-param ( src reg rep -- )
+ reg src rep %copy ;
+
+M:: x86 %store-stack-param ( src n rep -- )
+ n param@ src rep %copy ;
+
+M:: x86 %store-return ( src rep -- )
+ rep reg-class-of return-reg src rep %copy ;
+
+HOOK: struct-return@ cpu ( n -- operand )
+
+M: x86 %prepare-struct-area ( dst -- )
+ f struct-return@ LEA ;
+
+M: x86 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
M: x86 %loop-entry 16 alignment [ NOP ] times ;
set-context-object primitives */
cell context_objects[context_object_count];
+ /* temporary area used by FFI code generation */
+ s64 long_long_return;
+
context(cell datastack_size, cell retainstack_size, cell callstack_size);
~context();
}
}
-VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent)
{
- return parent->to_signed_8(obj);
+ parent->ctx->long_long_return = parent->to_signed_8(obj);
+ return &parent->ctx->long_long_return;
}
cell factor_vm::from_unsigned_8(u64 n)
}
}
-VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent)
{
- return parent->to_unsigned_8(obj);
+ parent->ctx->long_long_return = parent->to_unsigned_8(obj);
+ return &parent->ctx->long_long_return;
}
VM_C_API cell from_float(float flo, factor_vm *parent)
projects / factor.git / commitdiff