From 5b48cd2a635bdcc5152ca6458250aafdfaa3e550 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 May 2010 03:43:02 -0400 Subject: [PATCH] FFI rewrite part 5: return value boxing and callback parameter boxing now uses vregs; simplify return value unboxing --- basis/alien/arrays/arrays.factor | 4 - basis/alien/c-types/c-types-docs.factor | 5 - basis/alien/c-types/c-types.factor | 13 +- basis/classes/struct/struct.factor | 8 - .../build-stack-frame.factor | 14 +- basis/compiler/cfg/builder/alien/alien.factor | 278 +++++------------- .../cfg/builder/alien/boxing/authors.txt | 1 + .../cfg/builder/alien/boxing/boxing.factor | 137 +++++++++ .../cfg/builder/alien/params/params.factor | 36 ++- .../cfg/instructions/instructions.factor | 66 ++--- .../linear-scan/allocation/allocation.factor | 38 ++- .../live-intervals/live-intervals.factor | 7 +- .../cfg/stack-frame/stack-frame.factor | 12 +- basis/compiler/codegen/codegen.factor | 11 +- basis/cpu/architecture/architecture.factor | 51 +--- basis/cpu/ppc/linux/linux.factor | 6 +- basis/cpu/ppc/macosx/macosx.factor | 6 +- basis/cpu/ppc/ppc.factor | 16 +- basis/cpu/x86/32/32.factor | 176 ++++------- basis/cpu/x86/64/64-tests.factor | 5 +- basis/cpu/x86/64/64.factor | 124 +++----- basis/cpu/x86/64/unix/unix.factor | 18 +- basis/cpu/x86/64/winnt/winnt.factor | 15 +- basis/cpu/x86/features/features.factor | 27 +- basis/cpu/x86/x86.factor | 48 +-- basis/math/floats/env/x86/64/64.factor | 12 +- basis/stack-checker/alien/alien.factor | 17 +- vm/alien.cpp | 43 --- vm/alien.hpp | 3 - vm/byte_arrays.cpp | 5 + vm/byte_arrays.hpp | 2 + vm/vm.hpp | 3 - 32 files changed, 520 insertions(+), 687 deletions(-) create mode 100644 basis/compiler/cfg/builder/alien/boxing/authors.txt create mode 100644 basis/compiler/cfg/builder/alien/boxing/boxing.factor diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index a58549627c..42e40483f6 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -24,8 +24,6 @@ M: array c-type-align-first first c-type-align-first ; M: array base-type drop void* base-type ; -M: array stack-size drop void* stack-size ; - PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; @@ -43,8 +41,6 @@ M: string-type c-type-align-first drop void* c-type-align-first ; M: string-type base-type drop void* base-type ; -M: string-type stack-size drop void* stack-size ; - M: string-type c-type-rep drop int-rep ; M: string-type c-type-boxer-quot diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index bf26dd5f88..27a2729194 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -14,11 +14,6 @@ HELP: heap-size } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; -HELP: stack-size -{ $values { "name" "a C type name" } { "size" math:integer } } -{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } -{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; - HELP: { $values { "c-type" c-type } } { $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 03c35d6251..7bcb59997d 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -17,8 +17,7 @@ SYMBOLS: long ulong longlong ulonglong float double - void* bool - (stack-value) ; + void* bool ; SINGLETON: void @@ -114,10 +113,6 @@ GENERIC: heap-size ( name -- size ) M: abstract-c-type heap-size size>> ; -GENERIC: stack-size ( name -- size ) - -M: c-type stack-size size>> cell align ; - MIXIN: value-type : c-getter ( name -- quot ) @@ -144,8 +139,7 @@ PROTOCOL: c-type-protocol c-type-align c-type-align-first base-type - heap-size - stack-size ; + heap-size ; CONSULT: c-type-protocol c-type-name c-type ; @@ -448,9 +442,6 @@ M: pointer c-type object >>boxed-class \ bool define-primitive-type - \ void* c-type clone stack-params >>rep - \ (stack-value) define-primitive-type - ] with-compilation-unit M: char-16-rep rep-component-type drop char ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 37cea6b9f2..5a0f21c750 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -168,14 +168,6 @@ M: struct-c-type c-type ; M: struct-c-type base-type ; -M: struct-c-type stack-size - dup value-struct? [ heap-size cell align ] [ drop cell ] if ; - -HOOK: flatten-struct-type cpu ( type -- pairs ) - -M: object flatten-struct-type - stack-size cell /i { int-rep f } ; - : large-struct? ( type -- ? ) { { [ dup void? ] [ drop f ] } diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 747e0f54cf..1fc9e5ed78 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces accessors math.order assocs kernel sequences +USING: namespaces accessors math math.order assocs kernel sequences combinators classes words cpu.architecture layouts compiler.cfg compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stack-frame ; @@ -17,13 +17,15 @@ GENERIC: compute-stack-frame* ( insn -- ) M: ##stack-frame compute-stack-frame* stack-frame>> request-stack-frame ; -M: ##call compute-stack-frame* drop frame-required? on ; - M: ##call-gc compute-stack-frame* drop frame-required? on stack-frame new t >>calls-vm? request-stack-frame ; +M: ##call compute-stack-frame* drop frame-required? on ; + +M: ##alien-callback compute-stack-frame* drop frame-required? on ; + M: insn compute-stack-frame* class "frame-required?" word-prop [ frame-required? on ] when ; @@ -31,10 +33,10 @@ M: insn compute-stack-frame* : initial-stack-frame ( -- stack-frame ) stack-frame new cfg get spill-area-size>> >>spill-area-size ; -: compute-stack-frame ( insns -- ) - frame-required? off +: compute-stack-frame ( cfg -- ) initial-stack-frame stack-frame set - [ instructions>> [ compute-stack-frame* ] each ] each-basic-block + [ spill-area-size>> 0 > frame-required? set ] + [ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ] bi stack-frame get dup stack-frame-size >>total-size drop ; : build-stack-frame ( cfg -- cfg ) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 3f529fce9d..293a984047 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -1,100 +1,54 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays layouts math math.order math.parser -combinators combinators.short-circuit fry make sequences locals -alien alien.private alien.strings alien.c-types alien.libraries -classes.struct namespaces kernel strings libc quotations words -cpu.architecture compiler.utilities compiler.tree compiler.cfg +combinators combinators.short-circuit fry make sequences +sequences.generalizations alien alien.private alien.strings +alien.c-types alien.libraries classes.struct namespaces kernel +strings libc locals quotations words cpu.architecture +compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.alien.params -compiler.cfg.builder.blocks compiler.cfg.instructions -compiler.cfg.stack-frame compiler.cfg.stacks -compiler.cfg.registers compiler.cfg.hats ; +compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks +compiler.cfg.instructions compiler.cfg.stack-frame +compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien -! output is triples with shape { vreg rep on-stack? } -GENERIC: unbox ( src c-type -- vregs ) - -M: c-type unbox - [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi - f 3array 1array ; - -M: long-long-type unbox - unboxer>> int-rep ^^unbox - 0 cell - [ - int-rep f ^^load-memory-imm - int-rep long-long-on-stack? 3array - ] bi-curry@ bi 2array ; - -GENERIC: unbox-parameter ( src c-type -- vregs ) - -M: c-type unbox-parameter unbox ; - -M: long-long-type unbox-parameter unbox ; - -M:: struct-c-type unbox-parameter ( src c-type -- ) - src ^^unbox-any-c-ptr :> src - c-type value-struct? [ - c-type flatten-struct-type - [| pair i | - src i cells pair first f ^^load-memory-imm - pair first2 3array - ] map-index - ] [ { { src int-rep f } } ] if ; - -: unbox-parameters ( parameters -- vregs ) +: unbox-parameters ( parameters -- vregs reps ) [ [ length iota ] keep - [ - [ ^^peek ] [ base-type ] bi* - unbox-parameter - ] 2map concat + [ [ ^^peek ] [ base-type ] bi* unbox-parameter ] + 2 2 mnmap [ concat ] bi@ ] [ length neg ##inc-d ] bi ; -: prepare-struct-area ( vregs return -- vregs ) - #! 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. +: prepare-struct-caller ( vregs reps return -- vregs' reps' ) large-struct? [ - ^^prepare-struct-area int-rep struct-return-on-stack? - 3array prefix + [ ^^prepare-struct-caller prefix ] + [ int-rep struct-return-on-stack? 2array prefix ] bi* ] when ; -: (objects>registers) ( vregs -- ) +: caller-parameter ( vreg rep on-stack? -- insn ) + [ dup reg-class-of reg-class-full? ] dip or + [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] + [ [ next-reg-param ] keep \ ##store-reg-param new-insn ] + if ; + +: (caller-parameters) ( vregs reps -- ) ! Place ##store-stack-param instructions first. This ensures ! that no registers are used after the ##store-reg-param ! instructions. - [ - first3 [ dup reg-class-of reg-class-full? ] dip or - [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] - [ [ next-reg-param ] keep \ ##store-reg-param new-insn ] - if - ] map [ ##store-stack-param? ] partition [ % ] bi@ ; + [ first2 caller-parameter ] 2map + [ ##store-stack-param? ] partition [ % ] bi@ ; -: objects>registers ( params -- stack-size ) +: caller-parameters ( params -- stack-size ) [ abi>> ] [ parameters>> ] [ return>> ] tri '[ _ unbox-parameters - _ prepare-struct-area - (objects>registers) + _ prepare-struct-caller + (caller-parameters) stack-params get ] with-param-regs ; -GENERIC: box-return ( c-type -- dst ) - -M: c-type box-return - [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ; - -M: long-long-type box-return - [ f ] dip boxer>> ^^box-long-long ; - -M: struct-c-type box-return - dup return-struct-in-registers? - [ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ; - : box-return* ( node -- ) return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; @@ -126,13 +80,8 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; bi 2dup check-dlsym ; : return-size ( c-type -- n ) - #! Amount of space we reserve for a return value. - { - { [ dup void? ] [ drop 0 ] } - { [ dup base-type struct-c-type? not ] [ drop 0 ] } - { [ dup large-struct? not ] [ drop 2 cells ] } - [ heap-size ] - } cond ; + ! Amount of space we reserve for a return value. + dup large-struct? [ heap-size ] [ drop 0 ] if ; : alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; @@ -158,7 +107,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; M: #alien-invoke emit-node [ { - [ objects>registers ] + [ caller-parameters ] [ alien-invoke-dlsym ##alien-invoke ] [ emit-stack-frame ] [ box-return* ] @@ -169,7 +118,7 @@ M:: #alien-indirect emit-node ( node -- ) node [ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src { - [ objects>registers ] + [ caller-parameters ] [ drop src ##alien-indirect ] [ emit-stack-frame ] [ box-return* ] @@ -179,132 +128,52 @@ M:: #alien-indirect emit-node ( node -- ) M: #alien-assembly emit-node [ { - [ objects>registers ] + [ caller-parameters ] [ quot>> ##alien-assembly ] [ emit-stack-frame ] [ box-return* ] } cleave ] emit-alien-block ; -GENERIC: box-parameter ( n c-type -- dst ) - -M: c-type box-parameter - [ rep>> ] [ boxer>> ] bi ^^box ; - -M: long-long-type box-parameter - boxer>> ^^box-long-long ; - -: if-value-struct ( ctype true false -- ) - [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline - -M: struct-c-type box-parameter - [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ; - -: parameter-offsets ( types -- offsets ) - 0 [ stack-size + ] accumulate nip ; - -: prepare-parameters ( parameters -- offsets types indices ) - [ length iota ] [ parameter-offsets ] [ ] tri ; +: callee-parameter ( rep on-stack? -- dst insn ) + [ next-vreg dup ] 2dip + [ dup reg-class-of reg-class-full? ] dip or + [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ] + [ [ next-reg-param ] keep \ ##load-reg-param new-insn ] + if ; -: alien-parameters ( params -- seq ) - [ parameters>> ] [ return>> large-struct? ] bi - [ struct-return-on-stack? (stack-value) void* ? prefix ] when ; +: prepare-struct-callee ( c-type -- vreg ) + large-struct? + [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ; -: box-parameters ( params -- ) - alien-parameters - [ length ##inc-d ] +: (callee-parameters) ( params -- vregs reps ) + [ flatten-parameter-type ] map [ - prepare-parameters - [ - next-vreg next-vreg ##save-context - base-type box-parameter swap ##replace - ] 3each - ] bi ; - -:: alloc-parameter ( rep -- reg rep ) - rep dup reg-class-of reg-class-full? - [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ; - -GENERIC: flatten-c-type ( type -- reps ) - -M: struct-c-type flatten-c-type - flatten-struct-type [ first2 [ drop stack-params ] when ] map ; - -M: long-long-type flatten-c-type drop { int-rep int-rep } ; - -M: c-type flatten-c-type - rep>> { - { int-rep [ { int-rep } ] } - { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] } - { double-rep [ - float-on-stack? - cell 4 = { stack-params stack-params } { stack-params } ? - { double-rep } ? - ] } - { stack-params [ { stack-params } ] } - } case ; - -M: object flatten-c-type base-type flatten-c-type ; - -: flatten-c-types ( types -- reps ) - [ flatten-c-type ] map concat ; - -: (registers>objects) ( params -- ) - [ 0 ] dip alien-parameters flatten-c-types [ - [ alloc-parameter ##save-param-reg ] - [ rep-size cell align + ] - 2bi - ] each drop ; inline - -: registers>objects ( params -- ) - ! Generate code for boxing input parameters in a callback. - dup abi>> [ - dup (registers>objects) - ##begin-callback - next-vreg next-vreg ##restore-context - box-parameters - ] with-param-regs ; - -: callback-return-quot ( ctype -- quot ) - return>> { - { [ dup void? ] [ drop [ ] ] } - { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } - [ c-type c-type-unboxer-quot ] - } cond ; - -: callback-prep-quot ( params -- quot ) - parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; + [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap + concat [ ##load-reg-param? ] partition [ % ] bi@ + ] keep ; -: wrap-callback-quot ( params -- quot ) - [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append - yield-hook get - '[ _ _ do-callback ] - >quotation ; - -GENERIC: unbox-return ( src c-type -- ) - -M: c-type unbox-return - unbox first first2 ##store-return ; - -M: long-long-type unbox-return - unbox first2 [ first ] bi@ ##store-long-long-return ; - -M: struct-c-type unbox-return - [ ^^unbox-any-c-ptr ] dip ##store-struct-return ; - -: emit-callback-stack-frame ( params -- ) - [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi - ##stack-frame ; +: box-parameters ( vregs reps params -- ) + ##begin-callback + next-vreg next-vreg ##restore-context + [ + next-vreg next-vreg ##save-context + box-parameter + 1 ##inc-d D 0 ##replace + ] 3each ; -: stack-args-size ( params -- n ) - dup abi>> [ - alien-parameters flatten-c-types - [ alloc-parameter 2drop ] each +: callee-parameters ( params -- stack-size ) + [ abi>> ] [ return>> ] [ parameters>> ] tri + '[ + _ prepare-struct-callee struct-return-area set + _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi stack-params get - ] with-param-regs ; + struct-return-area get + ] with-param-regs + struct-return-area set ; -: callback-stack-cleanup ( params -- ) - [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi +: callback-stack-cleanup ( stack-size params -- ) + [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi "stack-cleanup" set-word-prop ; M: #alien-callback emit-node @@ -313,21 +182,16 @@ M: #alien-callback emit-node ##prologue [ { - [ registers>objects ] - [ emit-callback-stack-frame ] - [ callback-stack-cleanup ] - [ wrap-callback-quot ##alien-callback ] + [ callee-parameters ] + [ quot>> ##alien-callback ] [ - return>> { - { [ dup void? ] [ drop ##end-callback ] } - { [ dup large-struct? ] [ drop ##end-callback ] } - [ - [ D 0 ^^peek ] dip - ##end-callback - base-type unbox-return - ] - } cond + return>> [ ##end-callback ] [ + [ D 0 ^^peek ] dip + ##end-callback + base-type unbox-return + ] if-void ] + [ callback-stack-cleanup ] } cleave ] emit-alien-block ##epilogue diff --git a/basis/compiler/cfg/builder/alien/boxing/authors.txt b/basis/compiler/cfg/builder/alien/boxing/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/boxing/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor new file mode 100644 index 0000000000..e535c1794f --- /dev/null +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -0,0 +1,137 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types arrays assocs classes.struct fry +kernel layouts locals math namespaces sequences +sequences.generalizations system +compiler.cfg.builder.alien.params compiler.cfg.hats +compiler.cfg.instructions cpu.architecture ; +IN: compiler.cfg.builder.alien.boxing + +SYMBOL: struct-return-area + +! pairs have shape { rep on-stack? } +GENERIC: flatten-c-type ( c-type -- pairs ) + +M: c-type flatten-c-type + rep>> f 2array 1array ; + +M: long-long-type flatten-c-type + drop 2 [ int-rep long-long-on-stack? 2array ] replicate ; + +HOOK: flatten-struct-type cpu ( type -- pairs ) + +M: object flatten-struct-type + heap-size cell align cell /i { int-rep f } ; + +M: struct-c-type flatten-c-type + flatten-struct-type ; + +: stack-size ( c-type -- n ) + base-type flatten-c-type keys 0 [ rep-size + ] reduce ; + +: component-offsets ( reps -- offsets ) + 0 [ rep-size + ] accumulate nip ; + +:: explode-struct ( src c-type -- vregs reps ) + c-type flatten-struct-type :> reps + reps keys dup component-offsets + [| rep offset | src offset rep f ^^load-memory-imm ] 2map + reps ; + +:: implode-struct ( src vregs reps -- ) + vregs reps dup component-offsets + [| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ; + +GENERIC: unbox ( src c-type -- vregs reps ) + +M: c-type unbox + [ unboxer>> ] [ rep>> ] bi + [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ; + +M: long-long-type unbox + unboxer>> int-rep ^^unbox + 0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array + int-rep long-long-on-stack? 2array dup 2array ; + +M: struct-c-type unbox ( src c-type -- vregs ) + [ ^^unbox-any-c-ptr ] dip explode-struct ; + +: frob-struct ( c-type -- c-type ) + dup value-struct? [ drop void* base-type ] unless ; + +GENERIC: unbox-parameter ( src c-type -- vregs reps ) + +M: c-type unbox-parameter unbox ; + +M: long-long-type unbox-parameter unbox ; + +M: struct-c-type unbox-parameter frob-struct unbox ; + +GENERIC: unbox-return ( src c-type -- ) + +: store-return ( vregs reps -- ) + [ + [ [ next-return-reg ] keep ##store-reg-param ] 2each + ] with-return-regs ; + +: (unbox-return) ( src c-type -- vregs reps ) + ! Don't care about on-stack? flag when looking at return + ! values. + unbox keys ; + +M: c-type unbox-return (unbox-return) store-return ; + +M: long-long-type unbox-return (unbox-return) store-return ; + +M: struct-c-type unbox-return + dup return-struct-in-registers? + [ unbox keys store-return ] + [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ; + +GENERIC: flatten-parameter-type ( c-type -- reps ) + +M: c-type flatten-parameter-type flatten-c-type ; + +M: long-long-type flatten-parameter-type flatten-c-type ; + +M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ; + +GENERIC: box ( vregs reps c-type -- dst ) + +M: c-type box + [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ; + +M: long-long-type box + [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ; + +M: struct-c-type box + '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip + implode-struct ; + +GENERIC: box-parameter ( vregs reps c-type -- dst ) + +M: c-type box-parameter box ; + +M: long-long-type box-parameter box ; + +M: struct-c-type box-parameter frob-struct box ; + +GENERIC: box-return ( c-type -- dst ) + +: load-return ( c-type -- vregs reps ) + [ + flatten-c-type keys + [ [ [ next-return-reg ] keep ^^load-reg-param ] keep ] + 1 2 mnmap + ] with-return-regs ; + +M: c-type box-return [ load-return ] keep box ; + +M: long-long-type box-return [ load-return ] keep box ; + +M: struct-c-type box-return + [ + dup return-struct-in-registers? + [ load-return ] + [ [ ^^prepare-struct-caller ] dip explode-struct keys ] if + ] keep box ; diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor index 85e9176c44..4509401af0 100644 --- a/basis/compiler/cfg/builder/alien/params/params.factor +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -1,9 +1,11 @@ ! 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 ; +namespaces sequences vectors assocs ; IN: compiler.cfg.builder.alien.params +SYMBOL: stack-params + : alloc-stack-param ( rep -- n ) stack-params get [ rep-size cell align stack-params +@ ] dip ; @@ -23,27 +25,29 @@ IN: compiler.cfg.builder.alien.params GENERIC: next-reg-param ( rep -- reg ) M: int-rep next-reg-param - [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ; + [ ?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 ; + [ ?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 ; + [ ?dummy-stack-params ] [ ?dummy-int-params ] bi + float-regs get pop ; -M: reg-class reg-class-full? get empty? ; +: reg-class-full? ( reg-class -- ? ) get empty? ; : init-reg-class ( abi reg-class -- ) - [ swap param-regs >vector ] keep set ; + [ swap param-regs at >vector ] keep set ; + +: init-regs ( regs -- ) + [ >vector swap set ] assoc-each ; : with-param-regs ( abi quot -- ) - '[ - [ int-regs init-reg-class ] - [ float-regs init-reg-class ] bi - 0 stack-params set - @ - ] with-scope ; inline + '[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline + +: next-return-reg ( rep -- reg ) reg-class-of get pop ; + +: with-return-regs ( quot -- ) + '[ return-regs init-regs @ ] with-scope ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b469866668..2c1ac7aadb 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -641,35 +641,30 @@ 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: ##load-reg-param +def: dst +literal: reg rep ; -INSN: ##store-long-long-return -use: src1/int-rep src2/int-rep ; +INSN: ##load-stack-param +def: dst +literal: n rep ; -INSN: ##prepare-struct-area +INSN: ##prepare-struct-caller def: dst/int-rep ; INSN: ##box def: dst/tagged-rep -literal: n rep boxer ; +use: src +literal: boxer rep ; INSN: ##box-long-long def: dst/tagged-rep -literal: n boxer ; - -INSN: ##box-small-struct -def: dst/tagged-rep -literal: c-type ; +use: src1/int-rep src2/int-rep +literal: boxer ; -INSN: ##box-large-struct +INSN: ##allot-byte-array def: dst/tagged-rep -literal: n c-type ; +literal: size ; INSN: ##alien-invoke literal: symbols dll ; @@ -683,9 +678,6 @@ use: src/int-rep ; INSN: ##alien-assembly literal: quot ; -INSN: ##save-param-reg -literal: offset reg rep ; - INSN: ##begin-callback ; INSN: ##alien-callback @@ -849,27 +841,31 @@ UNION: conditional-branch-insn UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; -! Instructions that clobber registers -UNION: clobber-insn -##call-gc -##unary-float-function -##binary-float-function -##box -##box-long-long -##box-small-struct -##box-large-struct -##unbox +! Instructions that clobber registers. They receive inputs and +! produce outputs in spill slots. +UNION: hairy-clobber-insn +##load-reg-param ##store-reg-param -##store-return -##store-struct-return -##store-long-long-return +##call-gc ##alien-invoke ##alien-indirect ##alien-assembly -##save-param-reg ##begin-callback ##end-callback ; +! Instructions that clobber registers but are allowed to produce +! outputs in registers. Inputs are in spill slots, except for +! inputs coalesced with the output, in which case that input +! will be in a register. +UNION: clobber-insn +hairy-clobber-insn +##unary-float-function +##binary-float-function +##unbox +##box +##box-long-long +##allot-byte-array ; + ! Instructions that have complex expansions and require that the ! output registers are not equal to any of the input registers UNION: def-is-use-insn diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 361f5896fb..722698e789 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -36,31 +36,39 @@ IN: compiler.cfg.linear-scan.allocation [ drop assign-blocked-register ] } cond ; -: spill-at-sync-point ( n live-interval -- ? ) - ! If the live interval has a definition at 'n', don't spill - 2dup find-use - { [ ] [ def-rep>> ] } 1&& - [ 2drop t ] [ swap spill f ] if ; +: spill-at-sync-point? ( sync-point live-interval -- ? ) + ! If the live interval has a definition at a keep-dst? + ! sync-point, don't spill. + { + [ drop keep-dst?>> not ] + [ [ n>> ] dip find-use dup [ def-rep>> ] when not ] + } 2|| ; + +: spill-at-sync-point ( sync-point live-interval -- ? ) + 2dup spill-at-sync-point? + [ swap n>> spill f ] [ 2drop t ] if ; + +GENERIC: handle-progress* ( obj -- ) + +M: live-interval handle-progress* drop ; -: handle-sync-point ( n -- ) +M: sync-point handle-progress* active-intervals get values [ [ spill-at-sync-point ] with filter! drop ] with each ; -:: handle-progress ( n sync? -- ) - n { - [ progress set ] - [ deactivate-intervals ] - [ sync? [ handle-sync-point ] [ drop ] if ] - [ activate-intervals ] - } cleave ; +:: handle-progress ( n obj -- ) + n progress set + n deactivate-intervals + obj handle-progress* + n activate-intervals ; GENERIC: handle ( obj -- ) M: live-interval handle ( live-interval -- ) - [ start>> f handle-progress ] [ assign-register ] bi ; + [ [ start>> ] keep handle-progress ] [ assign-register ] bi ; M: sync-point handle ( sync-point -- ) - n>> t handle-progress ; + [ n>> ] keep handle-progress ; : smallest-heap ( heap1 heap2 -- heap ) ! If heap1 and heap2 have the same key, favors heap1. diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index d874d0b5fb..65f341feb8 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -134,7 +134,7 @@ M: vreg-insn compute-live-intervals* ( insn -- ) ] if ; ! A location where all registers have to be spilled -TUPLE: sync-point n ; +TUPLE: sync-point n keep-dst? ; C: sync-point @@ -143,8 +143,11 @@ SYMBOL: sync-points GENERIC: compute-sync-points* ( insn -- ) +M: hairy-clobber-insn compute-sync-points* + insn#>> f sync-points get push ; + M: clobber-insn compute-sync-points* - insn#>> sync-points get push ; + insn#>> t sync-points get push ; M: insn compute-sync-points* drop ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 8ad55d76d8..1018a95a61 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order namespaces accessors kernel layouts -combinators combinators.smart assocs sequences cpu.architecture +combinators assocs sequences cpu.architecture words compiler.cfg.instructions ; IN: compiler.cfg.stack-frame @@ -13,16 +13,14 @@ TUPLE: stack-frame { calls-vm? boolean } ; ! Stack frame utilities -: param-base ( -- n ) - stack-frame get [ params>> ] [ return>> ] bi + ; +: return-offset ( -- offset ) + stack-frame get params>> ; : spill-offset ( n -- offset ) - param-base + ; + stack-frame get [ params>> ] [ return>> ] bi + + ; : (stack-frame-size) ( stack-frame -- n ) - [ - [ params>> ] [ return>> ] [ spill-area-size>> ] tri - ] sum-outputs ; + [ params>> ] [ return>> ] [ spill-area-size>> ] tri + + ; : max-stack-frame ( frame1 frame2 -- frame3 ) [ stack-frame new ] 2dip diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index b787220b56..81e14bd68e 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -287,15 +287,12 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul 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: ##load-reg-param %load-reg-param +CODEGEN: ##load-stack-param %load-stack-param +CODEGEN: ##prepare-struct-caller %prepare-struct-caller 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: ##save-param-reg %save-param-reg +CODEGEN: ##allot-byte-array %allot-byte-array CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##cleanup %cleanup CODEGEN: ##alien-indirect %alien-indirect diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b0d2747ce0..fb4876d95f 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -150,9 +150,6 @@ SINGLETONS: int-regs float-regs ; UNION: reg-class int-regs float-regs ; CONSTANT: reg-classes { int-regs float-regs } -! A pseudo-register class for parameters spilled on the stack -SINGLETON: stack-params - ! On x86, vectors and floats are stored in the same register bank ! On PowerPC they are distinct HOOK: vector-regs cpu ( -- reg-class ) @@ -165,7 +162,6 @@ M: float-rep reg-class-of drop float-regs ; M: double-rep reg-class-of drop float-regs ; M: vector-rep reg-class-of drop vector-regs ; M: scalar-rep reg-class-of drop vector-regs ; -M: stack-params reg-class-of drop stack-params ; GENERIC: rep-size ( rep -- n ) foldable @@ -173,7 +169,6 @@ M: tagged-rep rep-size drop cell ; M: int-rep rep-size drop cell ; M: float-rep rep-size drop 4 ; M: double-rep rep-size drop 8 ; -M: stack-params rep-size drop cell ; M: vector-rep rep-size drop 16 ; M: char-scalar-rep rep-size drop 1 ; M: uchar-scalar-rep rep-size drop 1 ; @@ -507,22 +502,6 @@ HOOK: %reload cpu ( dst rep src -- ) HOOK: %loop-entry cpu ( -- ) -! FFI stuff - -! Return values of this class go here -GENERIC: return-reg ( reg-class -- reg ) - -! Sequence of registers used for parameter passing in class -GENERIC# param-regs 1 ( reg-class abi -- regs ) - -M: stack-params param-regs 2drop f ; - -GENERIC# param-reg 1 ( n reg-class abi -- reg ) - -M: reg-class param-reg param-regs nth ; - -M: stack-params param-reg 2drop ; - ! Does this architecture support %load-float, %load-double, ! and %load-vector? HOOK: fused-unboxing? cpu ( -- ? ) @@ -552,6 +531,14 @@ M: object immediate-comparand? ( n -- ? ) : immediate-shift-count? ( n -- ? ) 0 cell-bits 1 - between? ; +! FFI stuff + +! Return values of this class go here +HOOK: return-regs cpu ( -- regs ) + +! Registers used for parameter passing +HOOK: param-regs cpu ( abi -- regs ) + ! Is this structure small enough to be returned in registers? HOOK: return-struct-in-registers? cpu ( c-type -- ? ) @@ -584,26 +571,16 @@ HOOK: %store-reg-param cpu ( src reg rep -- ) HOOK: %store-stack-param cpu ( src n rep -- ) -HOOK: %store-return cpu ( src rep -- ) - -HOOK: %store-struct-return cpu ( src reps -- ) - -HOOK: %store-long-long-return cpu ( src1 src2 -- ) - -HOOK: %prepare-struct-area cpu ( dst -- ) +HOOK: %prepare-struct-caller cpu ( dst -- ) ! 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 -HOOK: %box cpu ( dst n rep func -- ) - -HOOK: %box-long-long cpu ( dst n func -- ) - -HOOK: %box-small-struct cpu ( dst c-type -- ) +HOOK: %box cpu ( dst src func rep -- ) -HOOK: %box-large-struct cpu ( dst n c-type -- ) +HOOK: %box-long-long cpu ( dst src1 src2 func -- ) -HOOK: %save-param-reg cpu ( stack reg rep -- ) +HOOK: %allot-byte-array cpu ( dst size -- ) HOOK: %restore-context cpu ( temp1 temp2 -- ) @@ -617,6 +594,10 @@ M: object %cleanup ( n -- ) drop ; HOOK: %alien-indirect cpu ( src -- ) +HOOK: %load-reg-param cpu ( dst reg rep -- ) + +HOOK: %load-stack-param cpu ( dst n rep -- ) + HOOK: %begin-callback cpu ( -- ) HOOK: %alien-callback cpu ( quot -- ) diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index 5912632513..9191b6c202 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -13,7 +13,11 @@ M: linux reserved-area-size 2 cells ; M: linux lr-save 1 cells ; -M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ; +M: ppc param-regs + drop { + { int-regs { 3 4 5 6 7 8 9 10 } } + { float-regs { 1 2 3 4 5 6 7 8 } } + } ; M: ppc value-struct? drop f ; diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor index 49e9768cf6..989426b8d2 100644 --- a/basis/cpu/ppc/macosx/macosx.factor +++ b/basis/cpu/ppc/macosx/macosx.factor @@ -8,7 +8,11 @@ M: macosx reserved-area-size 6 cells ; M: macosx lr-save 2 cells ; -M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; +M: ppc param-regs + drop { + { int-regs { 3 4 5 6 7 8 9 10 } } + { float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } + } ; M: ppc value-struct? drop t ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 233f5eb538..0708f7991f 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -226,10 +226,10 @@ M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ; M: integer float-function-param* FMR ; : float-function-param ( i src -- ) - [ float-regs cdecl param-regs nth ] dip float-function-param* ; + [ float-regs cdecl param-regs at nth ] dip float-function-param* ; : float-function-return ( reg -- ) - float-regs return-reg double-rep %copy ; + float-regs return-regs at first double-rep %copy ; M:: ppc %unary-float-function ( dst src func -- ) 0 src float-function-param @@ -665,11 +665,11 @@ M: ppc %reload ( dst rep src -- ) M: ppc %loop-entry ; -M: int-regs return-reg drop 3 ; - -M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ; - -M: float-regs return-reg drop 1 ; +M: ppc return-regs + { + { int-regs { 3 4 5 6 } } + { float-regs { 1 } } + } ; M:: ppc %save-param-reg ( stack reg rep -- ) reg stack local@ rep store-to-frame ; @@ -697,7 +697,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ; 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* ; + n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ; M:: ppc %unbox-long-long ( src n func -- ) src func call-unbox-func diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index f663523999..31800759f6 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: locals alien alien.c-types alien.libraries alien.syntax arrays kernel fry math namespaces sequences system layouts io -vocabs.loader accessors init classes.struct combinators -make words compiler.constants compiler.codegen.fixup -compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics -compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands -cpu.x86 cpu.architecture vm ; +vocabs.loader accessors init classes.struct combinators make +words compiler.constants compiler.codegen.fixup +compiler.cfg.instructions compiler.cfg.builder +compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics +compiler.cfg.stack-frame cpu.x86.assembler +cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ; FROM: layouts => cell ; IN: cpu.x86.32 @@ -20,19 +21,12 @@ M: x86.32 ds-reg ESI ; M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 frame-reg EBP ; -M: x86.32 temp-reg ECX ; M: x86.32 immediate-comparand? ( obj -- ? ) drop t ; 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-rep %load-vector ; - -M: x86.32 %load-double ( dst val -- ) - double-rep %load-vector ; - M: x86.32 %mov-vm-ptr ( reg -- ) 0 MOV 0 rc-absolute-cell rel-vm ; @@ -45,9 +39,6 @@ M: x86.32 %set-vm-field ( dst field -- ) M: x86.32 %vm-field-ptr ( dst field -- ) [ 0 MOV ] dip rc-absolute-cell rel-vm ; -: local@ ( n -- op ) - stack-frame get extra-stack-space dup 16 assert= + stack@ ; - M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ; M: x86.32 %mark-card @@ -80,8 +71,6 @@ M: x86.32 pic-tail-reg EDX ; M: x86.32 reserved-stack-space 0 ; -M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; - : save-vm-ptr ( n -- ) stack@ 0 MOV 0 rc-absolute-cell rel-vm ; @@ -94,64 +83,61 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? ) ! 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 } ] } - { fastcall [ { ECX EDX } ] } - [ drop { } ] +M: x86.32 param-regs + { + { thiscall [ { { int-regs { ECX } } { float-regs { } } } ] } + { fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] } + [ drop { { int-regs { } } { float-regs { } } } ] } case ; -GENERIC: load-return-reg ( src rep -- ) -GENERIC: store-return-reg ( dst rep -- ) +! Need a fake return-reg for floats +M: x86.32 return-regs + { + { int-regs { EAX EDX } } + { float-regs { f } } + } ; -M: stack-params load-return-reg drop EAX swap MOV ; -M: stack-params store-return-reg drop EAX MOV ; +M: x86.32 %prologue ( n -- ) + dup PUSH + 0 PUSH rc-absolute-cell rel-this + 3 cells - decr-stack-reg ; -M: int-rep load-return-reg drop EAX swap MOV ; -M: int-rep store-return-reg drop EAX MOV ; +M: x86.32 %prepare-jump + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; -:: load-float-return ( src x87-insn sse-insn -- ) - src register? [ +:: load-float-return ( dst x87-insn sse-insn -- ) + dst register? [ ESP 4 SUB - ESP [] src sse-insn execute ESP [] x87-insn execute + dst ESP [] sse-insn execute ESP 4 ADD ] [ - src x87-insn execute + dst x87-insn execute ] if ; inline -:: store-float-return ( dst x87-insn sse-insn -- ) - dst register? [ +M: x86.32 %load-reg-param ( dst reg rep -- ) + [ ?spill-slot ] dip { + { int-rep [ MOV ] } + { float-rep [ drop \ FSTPS \ MOVSS load-float-return ] } + { double-rep [ drop \ FSTPL \ MOVSD load-float-return ] } + } case ; + +:: store-float-return ( src x87-insn sse-insn -- ) + src register? [ ESP 4 SUB + ESP [] src sse-insn execute ESP [] x87-insn execute - dst ESP [] sse-insn execute ESP 4 ADD ] [ - dst x87-insn execute + src x87-insn execute ] if ; inline -M: float-rep load-return-reg - drop \ FLDS \ MOVSS load-float-return ; - -M: float-rep store-return-reg - drop \ FSTPS \ MOVSS store-float-return ; - -M: double-rep load-return-reg - drop \ FLDL \ MOVSD load-float-return ; - -M: double-rep store-return-reg - drop \ FSTPL \ MOVSD store-float-return ; - -M: x86.32 %prologue ( n -- ) - dup PUSH - 0 PUSH rc-absolute-cell rel-this - 3 cells - decr-stack-reg ; - -M: x86.32 %prepare-jump - pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; +M: x86.32 %store-reg-param ( src reg rep -- ) + [ ?spill-slot ] dip { + { int-rep [ swap MOV ] } + { float-rep [ \ FLDS \ MOVSS store-float-return ] } + { double-rep [ \ FLDL \ MOVSD store-float-return ] } + } case ; :: call-unbox-func ( src func -- ) EAX src tagged-rep %copy @@ -161,77 +147,29 @@ M: x86.32 %prepare-jump M:: x86.32 %unbox ( dst src func rep -- ) src func call-unbox-func - dst ?spill-slot rep store-return-reg ; - -M:: x86.32 %store-return ( src rep -- ) - src ?spill-slot rep load-return-reg ; - -M:: x86.32 %store-long-long-return ( src1 src2 -- ) - src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 ) - EAX src1 int-rep %copy - EDX src2 int-rep %copy ; + dst rep %load-return ; -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 - { - { [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] } - { [ over integer? ] [ EAX swap MOV param@ EAX MOV ] } - } cond ; - -M: x86.32 %save-param-reg [ local@ ] 2dip %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 - #! integer, push [ESP+n] on the stack; we are boxing a - #! parameter being passed to a callback from C. - over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ; - -M:: x86.32 %box ( dst n rep func -- ) - n rep (%box) +M:: x86.32 %box ( dst src func rep -- ) rep rep-size save-vm-ptr - 0 stack@ rep store-return-reg + src rep %store-return + 0 stack@ rep %load-return func f %alien-invoke dst EAX tagged-rep %copy ; -: (%box-long-long) ( n -- ) - [ - [ EDX swap next-stack@ MOV ] - [ EAX swap cell - next-stack@ MOV ] bi - ] when* ; - -M:: x86.32 %box-long-long ( dst n func -- ) - n (%box-long-long) +M:: x86.32 %box-long-long ( dst src1 src2 func -- ) 8 save-vm-ptr - 4 stack@ EDX MOV - 0 stack@ EAX MOV + 4 stack@ src1 int-rep %copy + 0 stack@ src2 int-rep %copy 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 - 4 stack@ c-type heap-size MOV - 0 stack@ EDX MOV - "from_value_struct" f %alien-invoke +M:: x86.32 %allot-byte-array ( dst size -- ) + 4 save-vm-ptr + 0 stack@ size MOV + "allot_byte_array" f %alien-invoke dst EAX tagged-rep %copy ; -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@ c-type heap-size MOV - 4 stack@ EDX MOV - 0 stack@ EAX MOV - "from_small_struct" f %alien-invoke - dst EAX tagged-rep %copy ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr @@ -309,7 +247,7 @@ M: x86.32 long-long-on-stack? t ; M: x86.32 float-on-stack? t ; M: x86.32 flatten-struct-type - stack-size cell /i { int-rep t } ; + call-next-method [ first t 2array ] map ; M: x86.32 struct-return-on-stack? os linux? not ; diff --git a/basis/cpu/x86/64/64-tests.factor b/basis/cpu/x86/64/64-tests.factor index 2d2c89441c..3ade9e9e7f 100644 --- a/basis/cpu/x86/64/64-tests.factor +++ b/basis/cpu/x86/64/64-tests.factor @@ -1,5 +1,6 @@ USING: alien alien.c-types cpu.architecture cpu.x86.64 -cpu.x86.assembler cpu.x86.assembler.operands tools.test ; +cpu.x86.assembler cpu.x86.assembler.operands tools.test +assocs sequences ; IN: cpu.x86.64.tests : assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ; @@ -9,7 +10,7 @@ IN: cpu.x86.64.tests : assembly-test-2 ( a b -- x ) int { int int } cdecl [ param-reg-0 param-reg-1 ADD - int-regs return-reg param-reg-0 MOV + int-regs return-regs at first param-reg-0 MOV ] alien-assembly ; [ 23 ] [ 17 6 assembly-test-2 ] unit-test diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 68bade8781..73f32c3be3 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -11,15 +11,20 @@ cpu.architecture vm ; FROM: layouts => cell cells ; IN: cpu.x86.64 -: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline -: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline -: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline -: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline +: param-reg ( n -- reg ) int-regs cdecl param-regs at nth ; + +: param-reg-0 ( -- reg ) 0 param-reg ; inline +: param-reg-1 ( -- reg ) 1 param-reg ; inline +: param-reg-2 ( -- reg ) 2 param-reg ; inline +: param-reg-3 ( -- reg ) 3 param-reg ; inline M: x86.64 pic-tail-reg RBX ; -M: int-regs return-reg drop RAX ; -M: float-regs return-reg drop XMM0 ; +M: x86.64 return-regs + { + { int-regs { RAX EDX } } + { float-regs { XMM0 XMM1 } } + } ; M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; @@ -49,18 +54,16 @@ M: x86.64 %vm-field ( dst offset -- ) 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-rep %load-vector ; - -M: x86.64 %load-double ( dst val -- ) - double-rep %load-vector ; - M: x86.64 %set-vm-field ( src offset -- ) [ vm-reg ] dip [+] swap MOV ; M: x86.64 %vm-field-ptr ( dst offset -- ) [ vm-reg ] dip [+] LEA ; +! Must be a volatile register not used for parameter passing or +! integer return +HOOK: temp-reg cpu ( -- reg ) + M: x86.64 %prologue ( n -- ) temp-reg -7 [RIP+] LEA dup PUSH @@ -99,85 +102,29 @@ M:: x86.64 %dispatch ( src temp -- ) [ (align-code) ] bi ; +M:: x86.64 %load-reg-param ( dst reg rep -- ) + dst reg rep %copy ; + +M:: x86.64 %store-reg-param ( src reg rep -- ) + reg src rep %copy ; + M:: x86.64 %unbox ( dst src func rep -- ) param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr func f %alien-invoke - dst rep reg-class-of return-reg rep %copy ; - -: with-return-regs ( quot -- ) - [ - V{ RDX RAX } clone int-regs set - V{ XMM1 XMM0 } clone float-regs set - call - ] with-scope ; inline - -: each-struct-component ( c-type quot -- ) - '[ - flatten-struct-type - [ [ first ] dip @ ] each-index - ] with-return-regs ; inline - -: %unbox-struct-component ( 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 %store-return ( src rep -- ) - rep reg-class-of return-reg src rep %copy ; - -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 - c-type [ %unbox-struct-component ] each-struct-component ; - -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 ; + dst rep %load-return ; -M:: x86.64 %box ( dst n rep func -- ) - 0 rep reg-class-of cdecl param-reg - n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy +M:: x86.64 %box ( dst src func rep -- ) + 0 rep reg-class-of cdecl param-regs at nth src rep %copy rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr func f %alien-invoke - dst RAX tagged-rep %copy ; - -: box-struct-component@ ( i -- operand ) 1 + cells param@ ; - -: %box-struct-component ( rep i -- ) - box-struct-component@ swap reg-class-of { - { int-regs [ int-regs get pop MOV ] } - { float-regs [ float-regs get pop MOVSD ] } - } case ; - -M:: x86.64 %box-small-struct ( dst c-type -- ) - #! Box a <= 16-byte struct. - c-type [ %box-struct-component ] each-struct-component - param-reg-2 c-type heap-size MOV - param-reg-0 0 box-struct-component@ MOV - param-reg-1 1 box-struct-component@ MOV - param-reg-3 %mov-vm-ptr - "from_small_struct" f %alien-invoke - dst RAX tagged-rep %copy ; - -M: x86.64 struct-return@ ( n -- operand ) - [ stack-frame get params>> ] unless* param@ ; - -M:: x86.64 %box-large-struct ( dst n c-type -- ) - ! Struct size is parameter 2 - param-reg-1 c-type heap-size MOV - ! Compute destination address - 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 - dst RAX tagged-rep %copy ; + dst int-rep %load-return ; + +M:: x86.64 %allot-byte-array ( dst size -- ) + param-reg-0 size MOV + param-reg-1 %mov-vm-ptr + "allot_byte_array" f %alien-invoke + dst int-rep %load-return ; M: x86.64 %alien-invoke R11 0 MOV @@ -198,15 +145,12 @@ M: x86.64 %end-callback ( -- ) "end_callback" f %alien-invoke ; : float-function-param ( i src -- ) - [ float-regs cdecl param-regs nth ] dip double-rep %copy ; - -: float-function-return ( reg -- ) - float-regs return-reg double-rep %copy ; + [ float-regs cdecl param-regs at nth ] dip double-rep %copy ; M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param func "libm" load-library %alien-invoke - dst float-function-return ; + dst double-rep %load-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! src1 might equal dst; otherwise it will be a spill slot @@ -214,7 +158,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) 0 src1 float-function-param 1 src2 float-function-param func "libm" load-library %alien-invoke - dst float-function-return ; + dst double-rep %load-return ; M:: x86.64 %call-gc ( gc-roots -- ) param-reg-0 gc-roots gc-root-offsets %load-reference diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index c7b8d4017a..4d75e55479 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -3,14 +3,18 @@ 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.cfg.builder.alien compiler.cfg.registers ; +cpu.x86 cpu.x86.64 compiler.cfg.builder.alien +compiler.cfg.builder.alien.boxing compiler.cfg.registers ; IN: cpu.x86.64.unix M: int-regs param-regs 2drop { RDI RSI RDX RCX R8 R9 } ; -M: float-regs param-regs - 2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; +M: x86.64 param-regs + drop { + { int-regs { RDI RSI RDX RCX R8 R9 } } + { float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } + } ; M: x86.64 reserved-stack-space 0 ; @@ -31,13 +35,9 @@ M: x86.64 reserved-stack-space 0 ; f 2array ] map ; -: flatten-large-struct ( c-type -- seq ) - stack-size cell /i { int-rep t } ; - M: x86.64 flatten-struct-type ( c-type -- seq ) - dup heap-size 16 > - [ flatten-large-struct ] - [ flatten-small-struct ] if ; + dup heap-size 16 <= + [ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ; M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 5d8ecc5cfb..011de59ccb 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -1,13 +1,15 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts system math alien.c-types sequences -compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 -cpu.x86.assembler.operands ; +compiler.cfg.registers cpu.architecture cpu.x86.assembler +cpu.x86 cpu.x86.64 cpu.x86.assembler.operands ; IN: cpu.x86.64.winnt -M: int-regs param-regs 2drop { RCX RDX R8 R9 } ; - -M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ; +M: x86.64 param-regs + drop { + { int-regs { RCX RDX R8 R9 } } + { float-regs { XMM0 XMM1 XMM2 XMM3 } } + } ; M: x86.64 reserved-stack-space 4 cells ; @@ -23,4 +25,3 @@ M: x86.64 dummy-int-params? t ; M: x86.64 dummy-fp-params? t ; M: x86.64 temp-reg R11 ; - diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index ce0a9dafdf..1cab105d27 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,13 +1,16 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types combinators compiler -compiler.codegen.fixup compiler.units cpu.architecture -cpu.x86.assembler cpu.x86.assembler.operands init io kernel -locals math math.order math.parser memoize namespaces system ; +USING: accessors assocs sequences alien alien.c-types +combinators compiler compiler.codegen.fixup compiler.units +cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands +init io kernel locals math math.order math.parser memoize +namespaces system ; IN: cpu.x86.features > spill-offset special-offset cell + ] map f like ; @@ -62,10 +58,6 @@ M: x86 stack-frame-size ( stack-frame -- i ) 3 cells + align-stack ; -! Must be a volatile register not used for parameter passing or -! integer return -HOOK: temp-reg cpu ( -- reg ) - HOOK: pic-tail-reg cpu ( -- reg ) M: x86 complex-addressing? t ; @@ -83,6 +75,12 @@ M: x86 %load-reference [ \ f type-number MOV ] if* ; +M: x86 %load-float ( dst val -- ) + float-rep %load-vector ; + +M: x86 %load-double ( dst val -- ) + double-rep %load-vector ; + HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) @@ -1500,16 +1498,27 @@ M:: x86 %spill ( src rep dst -- ) 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 ; + n reserved-stack-space + stack@ src rep %copy ; + +: %load-return ( dst rep -- ) + [ reg-class-of return-regs at first ] keep %load-reg-param ; + +: %store-return ( dst rep -- ) + [ reg-class-of return-regs at first ] keep %store-reg-param ; + +: next-stack@ ( n -- operand ) + #! nth parameter from the next stack frame. Used to box + #! input values to callbacks; the callback has its own + #! stack frame set up, and we want to read the frame + #! set up by the caller. + frame-reg swap 2 cells + [+] ; -HOOK: struct-return@ cpu ( n -- operand ) +M:: x86 %load-stack-param ( dst n rep -- ) + dst n next-stack@ rep %copy ; -M: x86 %prepare-struct-area ( dst -- ) - f struct-return@ LEA ; +M: x86 %prepare-struct-caller ( dst -- ) + return-offset special-offset stack@ LEA ; M: x86 %alien-indirect ( src -- ) ?spill-slot CALL ; @@ -1540,13 +1549,6 @@ M: x86 immediate-arithmetic? ( n -- ? ) M: x86 immediate-bitwise? ( n -- ? ) HEX: -80000000 HEX: 7fffffff between? ; -: next-stack@ ( n -- operand ) - #! nth parameter from the next stack frame. Used to box - #! input values to callbacks; the callback has its own - #! stack frame set up, and we want to read the frame - #! set up by the caller. - frame-reg swap 2 cells + [+] ; - enable-min/max enable-log2 diff --git a/basis/math/floats/env/x86/64/64.factor b/basis/math/floats/env/x86/64/64.factor index 93cb11104f..7013b8e52d 100644 --- a/basis/math/floats/env/x86/64/64.factor +++ b/basis/math/floats/env/x86/64/64.factor @@ -1,25 +1,25 @@ -USING: alien alien.c-types cpu.architecture cpu.x86.assembler +USING: alien alien.c-types cpu.x86.64 cpu.x86.assembler cpu.x86.assembler.operands math.floats.env.x86 sequences system ; IN: math.floats.env.x86.64 M: x86.64 get-sse-env void { void* } cdecl [ - int-regs cdecl param-regs first [] STMXCSR + param-reg-0 [] STMXCSR ] alien-assembly ; M: x86.64 set-sse-env void { void* } cdecl [ - int-regs cdecl param-regs first [] LDMXCSR + param-reg-0 [] LDMXCSR ] alien-assembly ; M: x86.64 get-x87-env void { void* } cdecl [ - int-regs cdecl param-regs first [] FNSTSW - int-regs cdecl param-regs first 2 [+] FNSTCW + param-reg-0 [] FNSTSW + param-reg-0 2 [+] FNSTCW ] alien-assembly ; M: x86.64 set-x87-env void { void* } cdecl [ FNCLEX - int-regs cdecl param-regs first 2 [+] FLDCW + param-reg-0 2 [+] FLDCW ] alien-assembly ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 62dd65c5e0..4147f8f29f 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators math namespaces init sets words assocs alien.libraries alien alien.private -alien.c-types fry stack-checker.backend +alien.c-types fry quotations stack-checker.backend stack-checker.errors stack-checker.visitor -stack-checker.dependencies ; +stack-checker.dependencies compiler.utilities ; IN: stack-checker.alien TUPLE: alien-node-params return parameters abi in-d out-d ; @@ -104,6 +104,18 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : callback-bottom ( params -- ) xt>> '[ _ callback-xt ] infer-quot-here ; +: callback-return-quot ( ctype -- quot ) + return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ; + +: 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 ; + : infer-alien-callback ( -- ) alien-callback-params new pop-quot @@ -111,5 +123,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; pop-params pop-return "( callback )" >>xt + dup wrap-callback-quot >>quot dup callback-bottom #alien-callback, ; diff --git a/vm/alien.cpp b/vm/alien.cpp index 3d9289a28c..1fa86389a1 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -187,47 +187,4 @@ VM_C_API char *alien_offset(cell obj, factor_vm *parent) return parent->alien_offset(obj); } -/* For FFI callbacks receiving structs by value */ -cell factor_vm::from_value_struct(void *src, cell size) -{ - byte_array *bytes = allot_byte_array(size); - memcpy(bytes->data(),src,size); - return tag(bytes); -} - -VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent) -{ - return parent->from_value_struct(src,size); -} - -/* On some x86 OSes, structs <= 8 bytes are returned in registers. */ -cell factor_vm::from_small_struct(cell x, cell y, cell size) -{ - cell data[2]; - data[0] = x; - data[1] = y; - return from_value_struct(data,size); -} - -VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent) -{ - return parent->from_small_struct(x,y,size); -} - -/* On OS X/PPC, complex numbers are returned in registers. */ -cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size) -{ - cell data[4]; - data[0] = x1; - data[1] = x2; - data[2] = x3; - data[3] = x4; - return from_value_struct(data,size); -} - -VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent) -{ - return parent->from_medium_struct(x1, x2, x3, x4, size); -} - } diff --git a/vm/alien.hpp b/vm/alien.hpp index 2b530c6b83..cd0120db6f 100755 --- a/vm/alien.hpp +++ b/vm/alien.hpp @@ -4,8 +4,5 @@ namespace factor 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 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); } diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp index 1986b5d35c..d59563d81c 100644 --- a/vm/byte_arrays.cpp +++ b/vm/byte_arrays.cpp @@ -10,6 +10,11 @@ byte_array *factor_vm::allot_byte_array(cell size) return array; } +VM_C_API cell allot_byte_array(cell size, factor_vm *parent) +{ + return tag(parent->allot_byte_array(size)); +} + void factor_vm::primitive_byte_array() { cell size = unbox_array_size(); diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp index a96baff6ec..2da036709f 100755 --- a/vm/byte_arrays.hpp +++ b/vm/byte_arrays.hpp @@ -20,4 +20,6 @@ template byte_array *factor_vm::byte_array_from_value(Type *value return data; } +VM_C_API cell allot_byte_array(cell size, factor_vm *parent); + } diff --git a/vm/vm.hpp b/vm/vm.hpp index 8a3ee56e27..645e748ea4 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -615,9 +615,6 @@ struct factor_vm void primitive_dlclose(); void primitive_dll_validp(); char *alien_offset(cell obj); - 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); // quotations void primitive_jit_compile(); -- 2.34.1