steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

FFI rewrite part 4: parameter and return value unboxing redesign

db4
Slava Pestov 2010-05-11 19:11:31 -04:00
parent d1e2554ebf
commit eb802208d1
18 changed files with 379 additions and 340 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/classes/struct/struct.factor
View File

@ -166,16 +166,10 @@ INSTANCE: struct-c-type value-type
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 )

6
basis/compiler/alien/alien.factor
View File

@ -9,7 +9,5 @@ IN: compiler.alien
: 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 ;

211
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -1,121 +1,89 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays layouts math math.order math.parser
combinators fry sequences locals alien alien.private
combinators fry make sequences locals alien alien.private
alien.strings alien.c-types alien.libraries classes.struct
namespaces kernel strings libc quotations cpu.architecture
compiler.alien compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers
compiler.cfg.hats ;
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 ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
GENERIC: next-fastcall-param ( rep -- )
! output is triples with shape { vreg rep on-stack? }
GENERIC: unbox ( src c-type -- vregs )
: ?dummy-stack-params ( rep -- )
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
M: c-type unbox
[ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
f 3array 1array ;
: ?dummy-int-params ( rep -- )
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
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 ;
: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs inc ] when ;
GENERIC: unbox-parameter ( src c-type -- vregs )
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
M: c-type unbox-parameter unbox ;
M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
M: long-long-type unbox-parameter unbox ;
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
M:: struct-c-type unbox-parameter ( src c-type -- )
src ^^unbox-any-c-ptr :> src
c-type value-struct? [
c-type flatten-struct-type
[| rep i |
src i cells rep f ^^load-memory-imm
rep struct-on-stack? 3array
] map-index
] [ { { src int-rep f } } ] if ;
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
M: stack-params reg-class-full? 2drop t ;
M: reg-class reg-class-full?
[ get ] swap '[ _ param-regs length ] bi >= ;
: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
[ rep-size cell align stack-params +@ ] dip
stack-params dup ;
: alloc-fastcall-param ( rep -- n reg-class rep )
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
:: alloc-parameter ( rep abi -- reg rep )
rep dup reg-class-of abi reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
[ abi param-reg ] dip ;
: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-fastcall-counts call ] with-scope ; inline
:: move-parameters ( params word -- )
#! Moves values from C stack to registers (if word is
#! ##load-param-reg) and registers to C stack (if word is
#! ##save-param-reg).
0 params alien-parameters flatten-c-types [
[ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
[ rep-size cell align + ]
2bi
] each drop ; inline
: parameter-offsets ( types -- offsets )
0 [ stack-size + ] accumulate nip ;
: prepare-parameters ( parameters -- offsets types indices )
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
GENERIC: unbox-parameter ( src n c-type -- )
M: c-type unbox-parameter
[ rep>> ] [ unboxer>> ] bi ##unbox ;
M: long-long-type unbox-parameter
unboxer>> ##unbox-long-long ;
M: struct-c-type unbox-parameter
[ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ]
[ base-type unbox-parameter ]
if-value-struct ;
: unbox-parameters ( offset node -- )
parameters>> swap
'[
prepare-parameters
: unbox-parameters ( parameters -- vregs )
[
[ length iota <reversed> ] keep
[
[ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*
[ <ds-loc> ^^peek ] [ base-type ] bi*
unbox-parameter
] 3each
] 2map concat
]
[ length neg ##inc-d ]
bi ;
[ length neg ##inc-d ] bi ;
: prepare-box-struct ( node -- offset )
: 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.
return>> large-struct?
[ ##prepare-box-struct cell ] [ 0 ] if ;
large-struct? [
^^prepare-struct-area int-rep struct-return-on-stack?
3array prefix
] when ;
: (objects>registers) ( vregs -- )
! Place instructions in reverse order, so that the
! ##store-stack-param instructions come first. This is
! because they are not clobber-insns and so we avoid some
! spills that way.
[
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 reverse % ;
: 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
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-area
(objects>registers)
] with-param-regs ;
GENERIC: box-return ( c-type -- dst )
@ -126,6 +94,9 @@ M: c-type box-return
M: long-long-type box-return
[ f ] dip boxer>> ^^box-long-long ;
: if-small-struct ( c-type true false -- ? )
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
M: struct-c-type box-return
[ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
@ -189,13 +160,12 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
M: #alien-invoke emit-node
[
! Unbox parameters
dup objects>registers
! Call function
dup alien-invoke-dlsym ##alien-invoke
! Box return value
dup ##cleanup
box-return*
{
[ objects>registers ]
[ alien-invoke-dlsym ##alien-invoke ]
[ stack-cleanup ##cleanup ]
[ box-return* ]
} cleave
] emit-alien-node ;
M: #alien-indirect emit-node
@ -204,7 +174,7 @@ M: #alien-indirect emit-node
{
[ drop objects>registers ]
[ nip ##alien-indirect ]
[ drop ##cleanup ]
[ drop stack-cleanup ##cleanup ]
[ drop box-return* ]
} 2cleave
] emit-alien-node ;
@ -225,9 +195,18 @@ M: c-type box-parameter
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 <reversed> ] [ parameter-offsets ] [ ] tri ;
: box-parameters ( params -- )
alien-parameters
[ length ##inc-d ]
@ -239,10 +218,21 @@ M: struct-c-type box-parameter
] 3each
] bi ;
: registers>objects ( node -- )
:: alloc-parameter ( rep -- reg rep )
rep dup reg-class-of reg-class-full?
[ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;
: (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 \ ##save-param-reg move-parameters
dup abi>> [
dup (registers>objects)
##begin-callback
next-vreg next-vreg ##restore-context
box-parameters
@ -267,14 +257,13 @@ M: struct-c-type box-parameter
GENERIC: unbox-return ( src c-type -- )
M: c-type unbox-return
[ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;
unbox first first2 ##store-return ;
M: long-long-type unbox-return
[ f ] dip unboxer>> ##unbox-long-long ;
unbox first2 [ first ] bi@ ##store-long-long-return ;
M: struct-c-type unbox-return
[ ^^unbox-any-c-ptr ] dip
[ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ;
[ ^^unbox-any-c-ptr ] dip ##store-struct-return ;
M: #alien-callback emit-node
dup params>> xt>> dup
@ -284,11 +273,15 @@ M: #alien-callback emit-node
[ registers>objects ]
[ wrap-callback-quot ##alien-callback ]
[
alien-return [ ##end-callback ] [
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
] if-void
return>> {
{ [ dup void eq? ] [ drop ##end-callback ] }
{ [ dup large-struct? ] [ drop ##end-callback ] }
[
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
]
} cond
] tri
] emit-alien-node
##epilogue

1
basis/compiler/cfg/builder/alien/params/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

49
basis/compiler/cfg/builder/alien/params/params.factor Normal file
View File

@ -0,0 +1,49 @@
! 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

59
basis/compiler/cfg/instructions/instructions.factor
View File

@ -612,6 +612,33 @@ literal: offset ;
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 ;
@ -628,32 +655,11 @@ 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: symbols dll ;
INSN: ##cleanup
literal: params ;
literal: n ;
INSN: ##alien-indirect
use: src/int-rep ;
@ -815,11 +821,10 @@ UNION: clobber-insn
##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

24
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,7 +1,9 @@
! 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
@ -34,15 +36,15 @@ IN: compiler.cfg.linear-scan.allocation
[ 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 {
@ -69,11 +71,7 @@ M: sync-point handle ( sync-point -- )
} 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 ( -- )

2
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -39,7 +39,7 @@ ERROR: splitting-atomic-interval ;
: 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

71
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -145,34 +145,24 @@ H{
{ vreg 3 }
{ 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 } } }
{ 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 }
}
T{ live-interval
{ vreg 3 }
{ 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-rep float-rep }
}
f
] [
T{ live-interval
{ vreg 3 }
{ reg-class float-regs }
{ start 0 }
{ end 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
{ 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
! Don't insert reload if first usage is a def
[
T{ live-interval
{ vreg 4 }
@ -189,12 +179,45 @@ H{
{ 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 12 } }
{ reload-rep float-rep }
}
] [
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 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 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 16 } }
{ spill-rep float-rep }
}
T{ live-interval
{ vreg 5 }
{ 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 }
{ vreg 5 }
{ reg-class float-regs }
{ start 0 }
{ end 30 }
@ -206,28 +229,28 @@ H{
! 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 }

4
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -54,6 +54,10 @@ M: live-interval covers? ( insn# live-interval -- ? )
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 ;

15
basis/compiler/codegen/codegen.factor
View File

@ -276,20 +276,21 @@ CONDITIONAL: ##fixnum-sub %fixnum-sub
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

35
basis/cpu/architecture/architecture.factor
View File

@ -534,10 +534,6 @@ M: object immediate-comparand? ( n -- ? )
: 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 -- ? )
@ -553,15 +549,30 @@ HOOK: dummy-int-params? cpu ( -- ? )
! 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: %unbox-long-long cpu ( src n func -- )
HOOK: %store-reg-param cpu ( src reg rep -- )
HOOK: %unbox-small-struct cpu ( src c-type -- )
HOOK: %store-stack-param cpu ( src n rep -- )
HOOK: %unbox-large-struct cpu ( src n c-type -- )
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 -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
@ -570,25 +581,21 @@ HOOK: %box cpu ( dst n rep func -- )
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 -- )

2
basis/cpu/ppc/ppc.factor
View File

@ -769,8 +769,6 @@ M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
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?>> ;

96
basis/cpu/x86/32/32.factor
View File

@ -95,17 +95,14 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
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 ;
@ -133,6 +130,26 @@ M: x86.32 %prologue ( n -- )
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
{
@ -142,8 +159,6 @@ M: stack-params copy-register*
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
@ -172,6 +187,9 @@ M:: x86.32 %box-long-long ( dst n func -- )
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
@ -180,12 +198,6 @@ M:: x86.32 %box-large-struct ( dst n c-type -- )
"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
@ -195,46 +207,6 @@ M:: x86.32 %box-small-struct ( dst c-type -- )
"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
@ -280,7 +252,7 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
: 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 )
@ -301,8 +273,8 @@ M: x86.32 stack-cleanup ( 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
@ -315,12 +287,10 @@ M: x86.32 dummy-int-params? f ;
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 struct-return-pointer-type
os linux? void* (stack-value) ? ;
M: x86.32 structs-on-stack? t ;
M: x86.32 struct-return-on-stack? os linux? not ;
check-sse

98
basis/cpu/x86/64/64.factor
View File

@ -99,6 +99,33 @@ M:: x86.64 %dispatch ( src temp -- )
[ (align-code) ]
bi ;
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
: %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 %store-struct-return ( src c-type -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
[
c-type flatten-struct-type
[ %unbox-struct-field ] each-index
] with-return-regs ;
M: stack-params copy-register*
drop
{
@ -108,59 +135,9 @@ M: stack-params copy-register*
M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
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 -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
[
c-type flatten-struct-type
[ %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 ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of cdecl param-reg ]
[ reg-class-of return-reg ]
[ ]
tri %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 ;
@ -185,7 +162,7 @@ M:: x86.64 %box-small-struct ( dst c-type -- )
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 -- )
@ -198,20 +175,11 @@ 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
@ -249,7 +217,11 @@ M:: x86.64 %call-gc ( gc-roots -- )
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.

25
basis/cpu/x86/x86.factor
View File

@ -1443,10 +1443,31 @@ M: x86.64 %scalar>integer ( dst src rep -- )
} 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 ;

3
vm/contexts.hpp
View File

@ -36,6 +36,9 @@ struct context {
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();

10
vm/math.cpp
View File

@ -491,9 +491,10 @@ s64 factor_vm::to_signed_8(cell obj)
}
}
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)
@ -524,9 +525,10 @@ u64 factor_vm::to_unsigned_8(cell obj)
}
}
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)