compiler backend now dispatches on the os
Doug Coleman
parent
d736a8660d
commit
7cb3fdcfec
|
|
@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
|
|||
byte-arrays bit-arrays float-arrays combinators words ;
|
||||
IN: cpu.architecture
|
||||
|
||||
SYMBOL: compiler-backend
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
TUPLE: stack-params ;
|
||||
|
||||
|
|
@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
|
|||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj vreg -- )
|
||||
|
||||
HOOK: load-indirect compiler-backend ( obj reg -- )
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
HOOK: stack-frame compiler-backend ( frame-size -- n )
|
||||
HOOK: stack-frame cpu ( frame-size -- n )
|
||||
|
||||
: stack-frame* ( -- n )
|
||||
\ stack-frame get stack-frame ;
|
||||
|
||||
! Set up caller stack frame
|
||||
HOOK: %prologue compiler-backend ( n -- )
|
||||
HOOK: %prologue cpu ( n -- )
|
||||
|
||||
: %prologue-later \ %prologue-later , ;
|
||||
|
||||
! Tear down stack frame
|
||||
HOOK: %epilogue compiler-backend ( n -- )
|
||||
HOOK: %epilogue cpu ( n -- )
|
||||
|
||||
: %epilogue-later \ %epilogue-later , ;
|
||||
|
||||
! Store word XT in stack frame
|
||||
HOOK: %save-word-xt compiler-backend ( -- )
|
||||
HOOK: %save-word-xt cpu ( -- )
|
||||
|
||||
! Store dispatch branch XT in stack frame
|
||||
HOOK: %save-dispatch-xt compiler-backend ( -- )
|
||||
HOOK: %save-dispatch-xt cpu ( -- )
|
||||
|
||||
M: object %save-dispatch-xt %save-word-xt ;
|
||||
|
||||
! Call another word
|
||||
HOOK: %call compiler-backend ( word -- )
|
||||
HOOK: %call cpu ( word -- )
|
||||
|
||||
! Local jump for branches
|
||||
HOOK: %jump-label compiler-backend ( label -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-t compiler-backend ( label -- )
|
||||
HOOK: %jump-t cpu ( label -- )
|
||||
|
||||
HOOK: %dispatch compiler-backend ( -- )
|
||||
HOOK: %dispatch cpu ( -- )
|
||||
|
||||
HOOK: %dispatch-label compiler-backend ( word -- )
|
||||
HOOK: %dispatch-label cpu ( word -- )
|
||||
|
||||
! Return to caller
|
||||
HOOK: %return compiler-backend ( -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
! Change datastack height
|
||||
HOOK: %inc-d compiler-backend ( n -- )
|
||||
HOOK: %inc-d cpu ( n -- )
|
||||
|
||||
! Change callstack height
|
||||
HOOK: %inc-r compiler-backend ( n -- )
|
||||
HOOK: %inc-r cpu ( n -- )
|
||||
|
||||
! Load stack into vreg
|
||||
HOOK: %peek compiler-backend ( vreg loc -- )
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
|
||||
! Store vreg to stack
|
||||
HOOK: %replace compiler-backend ( vreg loc -- )
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
|
||||
! Box and unbox floats
|
||||
HOOK: %unbox-float compiler-backend ( dst src -- )
|
||||
HOOK: %box-float compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-float cpu ( dst src -- )
|
||||
HOOK: %box-float cpu ( dst src -- )
|
||||
|
||||
! FFI stuff
|
||||
|
||||
! Is this integer small enough to appear in value template
|
||||
! slots?
|
||||
HOOK: small-enough? compiler-backend ( n -- ? )
|
||||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? compiler-backend ( size -- ? )
|
||||
HOOK: struct-small-enough? cpu ( size -- ? )
|
||||
|
||||
! Do we pass explode value structs?
|
||||
HOOK: value-structs? compiler-backend ( -- ? )
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
||||
! If t, fp parameters are shadowed by dummy int parameters
|
||||
HOOK: fp-shadows-int? compiler-backend ( -- ? )
|
||||
HOOK: fp-shadows-int? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox compiler-backend ( -- )
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
|
||||
HOOK: %unbox compiler-backend ( n reg-class func -- )
|
||||
HOOK: %unbox cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %unbox-long-long compiler-backend ( n func -- )
|
||||
HOOK: %unbox-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %unbox-small-struct compiler-backend ( size -- )
|
||||
HOOK: %unbox-small-struct cpu ( size -- )
|
||||
|
||||
HOOK: %unbox-large-struct compiler-backend ( n size -- )
|
||||
HOOK: %unbox-large-struct cpu ( n size -- )
|
||||
|
||||
HOOK: %box compiler-backend ( n reg-class func -- )
|
||||
HOOK: %box cpu ( n reg-class func -- )
|
||||
|
||||
HOOK: %box-long-long compiler-backend ( n func -- )
|
||||
HOOK: %box-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %prepare-box-struct compiler-backend ( size -- )
|
||||
HOOK: %prepare-box-struct cpu ( size -- )
|
||||
|
||||
HOOK: %box-small-struct compiler-backend ( size -- )
|
||||
HOOK: %box-small-struct cpu ( size -- )
|
||||
|
||||
HOOK: %box-large-struct compiler-backend ( n size -- )
|
||||
HOOK: %box-large-struct cpu ( n size -- )
|
||||
|
||||
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
||||
|
||||
GENERIC: %load-param-reg ( stack reg reg-class -- )
|
||||
|
||||
HOOK: %prepare-alien-invoke compiler-backend ( -- )
|
||||
HOOK: %prepare-alien-invoke cpu ( -- )
|
||||
|
||||
HOOK: %prepare-var-args compiler-backend ( -- )
|
||||
HOOK: %prepare-var-args cpu ( -- )
|
||||
|
||||
M: object %prepare-var-args ;
|
||||
|
||||
HOOK: %alien-invoke compiler-backend ( function library -- )
|
||||
HOOK: %alien-invoke cpu ( function library -- )
|
||||
|
||||
HOOK: %cleanup compiler-backend ( alien-node -- )
|
||||
HOOK: %cleanup cpu ( alien-node -- )
|
||||
|
||||
HOOK: %alien-callback compiler-backend ( quot -- )
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-value compiler-backend ( ctype -- )
|
||||
HOOK: %callback-value cpu ( ctype -- )
|
||||
|
||||
! Return to caller with stdcall unwinding (only for x86)
|
||||
HOOK: %unwind compiler-backend ( n -- )
|
||||
HOOK: %unwind cpu ( n -- )
|
||||
|
||||
HOOK: %prepare-alien-indirect compiler-backend ( -- )
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect compiler-backend ( -- )
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
M: stack-params param-reg drop ;
|
||||
|
||||
|
|
@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
|
|||
] if-small-struct ;
|
||||
|
||||
! Alien accessors
|
||||
HOOK: %unbox-byte-array compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-byte-array cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-alien compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-f compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-f cpu ( dst src -- )
|
||||
|
||||
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
|
||||
HOOK: %box-alien compiler-backend ( dst src -- )
|
||||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
: operand ( var -- op ) get v>operand ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ IN: cpu.ppc.allot
|
|||
12 11 float tag-number ORI
|
||||
f fresh-object ;
|
||||
|
||||
M: ppc-backend %box-float ( dst src -- )
|
||||
M: ppc %box-float ( dst src -- )
|
||||
[ v>operand ] bi@ %allot-float 12 MR ;
|
||||
|
||||
: %allot-bignum ( #digits -- )
|
||||
|
|
@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: ppc-backend %box-alien ( dst src -- )
|
||||
M: ppc %box-alien ( dst src -- )
|
||||
{ "end" "f" } [ define-label ] each
|
||||
0 over v>operand 0 CMPI
|
||||
"f" get BEQ
|
||||
|
|
|
|||
|
|
@ -7,8 +7,6 @@ layouts classes words.private alien combinators
|
|||
compiler.constants ;
|
||||
IN: cpu.ppc.architecture
|
||||
|
||||
TUPLE: ppc-backend ;
|
||||
|
||||
! PowerPC register assignments
|
||||
! r3-r10, r16-r31: integer vregs
|
||||
! f0-f13: float vregs
|
||||
|
|
@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
|
|||
|
||||
: xt-save ( n -- i ) 2 cells - ;
|
||||
|
||||
M: ppc-backend stack-frame ( n -- i )
|
||||
M: ppc stack-frame ( n -- i )
|
||||
local@ factor-area-size + 4 cells align ;
|
||||
|
||||
M: temp-reg v>operand drop 11 ;
|
||||
|
|
@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
|
|||
M: immediate load-literal
|
||||
[ v>operand ] bi@ LOAD ;
|
||||
|
||||
M: ppc-backend load-indirect ( obj reg -- )
|
||||
M: ppc load-indirect ( obj reg -- )
|
||||
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
|
||||
dup 0 LWZ ;
|
||||
|
||||
M: ppc-backend %save-word-xt ( -- )
|
||||
M: ppc %save-word-xt ( -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
|
||||
|
||||
M: ppc-backend %prologue ( n -- )
|
||||
M: ppc %prologue ( n -- )
|
||||
0 MFLR
|
||||
1 1 pick neg ADDI
|
||||
11 1 pick xt-save STW
|
||||
|
|
@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
|
|||
11 1 pick next-save STW
|
||||
0 1 rot lr-save + STW ;
|
||||
|
||||
M: ppc-backend %epilogue ( n -- )
|
||||
M: ppc %epilogue ( n -- )
|
||||
#! At the end of each word that calls a subroutine, we store
|
||||
#! the previous link register value in r0 by popping it off
|
||||
#! the stack, set the link register to the contents of r0,
|
||||
|
|
@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
|
|||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
M: ppc-backend %call ( label -- ) BL ;
|
||||
M: ppc %call ( label -- ) BL ;
|
||||
|
||||
M: ppc-backend %jump-label ( label -- ) B ;
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
|
||||
M: ppc-backend %jump-t ( label -- )
|
||||
M: ppc %jump-t ( label -- )
|
||||
0 "flag" operand f v>operand CMPI BNE ;
|
||||
|
||||
M: ppc-backend %dispatch ( -- )
|
||||
M: ppc %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
|
||||
|
|
@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
|
|||
{ +scratch+ { { f "offset" } } }
|
||||
} with-template ;
|
||||
|
||||
M: ppc-backend %dispatch-label ( word -- )
|
||||
M: ppc %dispatch-label ( word -- )
|
||||
0 , rc-absolute-cell rel-word ;
|
||||
|
||||
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
|
||||
M: ppc %return ( -- ) %epilogue-later BLR ;
|
||||
|
||||
M: ppc-backend %unwind drop %return ;
|
||||
M: ppc %unwind drop %return ;
|
||||
|
||||
M: ppc-backend %peek ( vreg loc -- )
|
||||
M: ppc %peek ( vreg loc -- )
|
||||
>r v>operand r> loc>operand LWZ ;
|
||||
|
||||
M: ppc-backend %replace
|
||||
M: ppc %replace
|
||||
>r v>operand r> loc>operand STW ;
|
||||
|
||||
M: ppc-backend %unbox-float ( dst src -- )
|
||||
M: ppc %unbox-float ( dst src -- )
|
||||
[ v>operand ] bi@ float-offset LFD ;
|
||||
|
||||
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
|
||||
M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
|
||||
|
||||
M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
|
||||
M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
|
||||
|
||||
M: int-regs %save-param-reg drop 1 rot local@ STW ;
|
||||
|
||||
|
|
@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
|
|||
0 1 rot param@ stack-frame* + LWZ
|
||||
0 1 rot local@ STW ;
|
||||
|
||||
M: ppc-backend %prepare-unbox ( -- )
|
||||
M: ppc %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup cell SUBI ;
|
||||
|
||||
M: ppc-backend %unbox ( n reg-class func -- )
|
||||
M: ppc %unbox ( n reg-class func -- )
|
||||
! Value must be in r3
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
! Store the return value on the C stack
|
||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||
|
||||
M: ppc-backend %unbox-long-long ( n func -- )
|
||||
M: ppc %unbox-long-long ( n func -- )
|
||||
! Value must be in r3:r4
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
|
|
@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
|
|||
4 1 rot cell + local@ STW
|
||||
] when* ;
|
||||
|
||||
M: ppc-backend %unbox-large-struct ( n size -- )
|
||||
M: ppc %unbox-large-struct ( n size -- )
|
||||
! Value must be in r3
|
||||
! Compute destination address
|
||||
4 1 roll local@ ADDI
|
||||
|
|
@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
|
|||
! Call the function
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: ppc-backend %box ( n reg-class func -- )
|
||||
M: ppc %box ( n reg-class func -- )
|
||||
! If the source is a stack location, load it into freg #0.
|
||||
! If the source is f, then we assume the value is already in
|
||||
! freg #0.
|
||||
|
|
@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
|
|||
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
|
||||
r> f %alien-invoke ;
|
||||
|
||||
M: ppc-backend %box-long-long ( n func -- )
|
||||
M: ppc %box-long-long ( n func -- )
|
||||
>r [
|
||||
3 1 pick local@ LWZ
|
||||
4 1 rot cell + local@ LWZ
|
||||
|
|
@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
|
|||
|
||||
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
|
||||
|
||||
M: ppc-backend %prepare-box-struct ( size -- )
|
||||
M: ppc %prepare-box-struct ( size -- )
|
||||
#! Compute target address for value struct return
|
||||
3 1 rot f struct-return@ ADDI
|
||||
3 1 0 local@ STW ;
|
||||
|
||||
M: ppc-backend %box-large-struct ( n size -- )
|
||||
M: ppc %box-large-struct ( n size -- )
|
||||
#! If n = f, then we're boxing a returned struct
|
||||
[ swap struct-return@ ] keep
|
||||
! Compute destination address
|
||||
|
|
@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
|
|||
! Call the function
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: ppc-backend %prepare-alien-invoke
|
||||
M: ppc %prepare-alien-invoke
|
||||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
|
|
@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
|
|||
ds-reg 11 8 STW
|
||||
rs-reg 11 12 STW ;
|
||||
|
||||
M: ppc-backend %alien-invoke ( symbol dll -- )
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym (%call) ;
|
||||
|
||||
M: ppc-backend %alien-callback ( quot -- )
|
||||
M: ppc %alien-callback ( quot -- )
|
||||
3 load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: ppc-backend %prepare-alien-indirect ( -- )
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
3 1 cell temp@ STW ;
|
||||
|
||||
M: ppc-backend %alien-indirect ( -- )
|
||||
M: ppc %alien-indirect ( -- )
|
||||
11 1 cell temp@ LWZ (%call) ;
|
||||
|
||||
M: ppc-backend %callback-value ( ctype -- )
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
3 ds-reg 0 LWZ
|
||||
3 1 0 local@ STW
|
||||
|
|
@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
|
|||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: ppc-backend %cleanup ( alien-node -- ) drop ;
|
||||
M: ppc %cleanup ( alien-node -- ) drop ;
|
||||
|
||||
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
|
||||
|
||||
|
|
@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
|
|||
|
||||
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
|
||||
|
||||
M: ppc-backend value-structs?
|
||||
M: ppc value-structs?
|
||||
#! On Linux/PPC, value structs are passed in the same way
|
||||
#! as reference structs, we just have to make a copy first.
|
||||
linux? not ;
|
||||
|
||||
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
|
||||
M: ppc fp-shadows-int? ( -- ? ) macosx? ;
|
||||
|
||||
M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
|
||||
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||
|
||||
M: ppc-backend %box-small-struct
|
||||
M: ppc %box-small-struct
|
||||
drop "No small structs" throw ;
|
||||
|
||||
M: ppc-backend %unbox-small-struct
|
||||
M: ppc %unbox-small-struct
|
||||
drop "No small structs" throw ;
|
||||
|
||||
! Alien intrinsics
|
||||
M: ppc-backend %unbox-byte-array ( dst src -- )
|
||||
M: ppc %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] bi@ byte-array-offset ADDI ;
|
||||
|
||||
M: ppc-backend %unbox-alien ( dst src -- )
|
||||
M: ppc %unbox-alien ( dst src -- )
|
||||
[ v>operand ] bi@ alien-offset LWZ ;
|
||||
|
||||
M: ppc-backend %unbox-f ( dst src -- )
|
||||
M: ppc %unbox-f ( dst src -- )
|
||||
drop 0 swap v>operand LI ;
|
||||
|
||||
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
|
||||
M: ppc %unbox-any-c-ptr ( dst src -- )
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
! Address is computed in R12
|
||||
0 12 LI
|
||||
|
|
|
|||
|
|
@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ;
|
|||
] }
|
||||
} cond
|
||||
|
||||
T{ ppc-backend } compiler-backend set-global
|
||||
|
||||
macosx? [
|
||||
4 "double" c-type set-c-type-align
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -8,23 +8,20 @@ alien.compiler combinators command-line
|
|||
compiler compiler.units io vocabs.loader accessors ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
PREDICATE: x86-32-backend < x86-backend
|
||||
x86-backend-cell 4 = ;
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
! OS X requires that the stack be 16-byte aligned, and we do
|
||||
! this on all platforms, sacrificing some stack space for
|
||||
! code simplicity.
|
||||
|
||||
M: x86-32-backend ds-reg ESI ;
|
||||
M: x86-32-backend rs-reg EDI ;
|
||||
M: x86-32-backend stack-reg ESP ;
|
||||
M: x86-32-backend xt-reg ECX ;
|
||||
M: x86-32-backend stack-save-reg EDX ;
|
||||
M: x86.32 ds-reg ESI ;
|
||||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 xt-reg ECX ;
|
||||
M: x86.32 stack-save-reg EDX ;
|
||||
|
||||
M: temp-reg v>operand drop EBX ;
|
||||
|
||||
M: x86-32-backend %alien-invoke ( symbol dll -- )
|
||||
M: x86.32 %alien-invoke ( symbol dll -- )
|
||||
(CALL) rel-dlsym ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
|
|
@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
|
|||
|
||||
! On x86, we can always use an address as an operand
|
||||
! directly.
|
||||
M: x86-32-backend address-operand ;
|
||||
M: x86.32 address-operand ;
|
||||
|
||||
M: x86-32-backend fixnum>slot@ 1 SHR ;
|
||||
M: x86.32 fixnum>slot@ 1 SHR ;
|
||||
|
||||
M: x86-32-backend prepare-division CDQ ;
|
||||
M: x86.32 prepare-division CDQ ;
|
||||
|
||||
M: x86-32-backend load-indirect
|
||||
M: x86.32 load-indirect
|
||||
0 [] MOV rc-absolute-cell rel-literal ;
|
||||
|
||||
M: object %load-param-reg 3drop ;
|
||||
|
||||
M: object %save-param-reg 3drop ;
|
||||
|
||||
M: x86-32-backend %prepare-unbox ( -- )
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
|
|
@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
|
|||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %unbox ( n reg-class func -- )
|
||||
M: x86.32 %unbox ( n reg-class func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
#! If n is f, we're unboxing a return value about to be
|
||||
#! returned by the callback. Otherwise, we're unboxing
|
||||
|
|
@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
|
|||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86-32-backend %unbox-long-long ( n func -- )
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
|
|
@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
|
|||
cell + stack@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
M: x86-32-backend %unbox-struct-2
|
||||
M: x86.32 %unbox-struct-2
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
|
|
@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
|
|||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %unbox-large-struct ( n size -- )
|
||||
M: x86.32 %unbox-large-struct ( n size -- )
|
||||
#! Alien must be in EAX.
|
||||
! Compute destination address
|
||||
ECX ESP roll [+] LEA
|
||||
|
|
@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
|
|||
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
|
||||
push-return-reg ;
|
||||
|
||||
M: x86-32-backend %box ( n reg-class func -- )
|
||||
M: x86.32 %box ( n reg-class func -- )
|
||||
over reg-size [
|
||||
>r (%box) r> f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
|
@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
|
|||
EDX PUSH
|
||||
EAX PUSH ;
|
||||
|
||||
M: x86-32-backend %box-long-long ( n func -- )
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
8 [
|
||||
>r (%box-long-long) r> f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %box-large-struct ( n size -- )
|
||||
M: x86.32 %box-large-struct ( n size -- )
|
||||
! Compute destination address
|
||||
[ swap struct-return@ ] keep
|
||||
ECX ESP roll [+] LEA
|
||||
|
|
@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
|
|||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %prepare-box-struct ( size -- )
|
||||
M: x86.32 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
EAX ESP rot f struct-return@ [+] LEA
|
||||
! Store it as the first parameter
|
||||
ESP [] EAX MOV ;
|
||||
|
||||
M: x86-32-backend %unbox-struct-1
|
||||
M: x86.32 %unbox-struct-1
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
|
|
@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
|
|||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %box-small-struct ( size -- )
|
||||
M: x86.32 %box-small-struct ( size -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
|
||||
12 [
|
||||
PUSH
|
||||
|
|
@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
|
|||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %prepare-alien-indirect ( -- )
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ EAX MOV ;
|
||||
|
||||
M: x86-32-backend %alien-indirect ( -- )
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: x86-32-backend %alien-callback ( quot -- )
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX load-indirect
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86-32-backend %callback-value ( ctype -- )
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack
|
||||
|
|
@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
|
|||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
M: x86-32-backend %cleanup ( alien-node -- )
|
||||
M: x86.32 %cleanup ( alien-node -- )
|
||||
#! a) If we just called an stdcall function in Windows, it
|
||||
#! cleaned up the stack frame for us. But we don't want that
|
||||
#! so we 'undo' the cleanup since we do that in %epilogue.
|
||||
|
|
@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- )
|
|||
}
|
||||
} cond ;
|
||||
|
||||
M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
|
||||
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
|
||||
|
||||
windows? [
|
||||
cell "longlong" c-type set-c-type-align
|
||||
|
|
@ -265,8 +262,6 @@ windows? [
|
|||
4 "double" c-type set-c-type-align
|
||||
] unless
|
||||
|
||||
T{ x86-backend f 4 } compiler-backend set-global
|
||||
|
||||
: sse2? "Intrinsic" throw ;
|
||||
|
||||
\ sse2? [
|
||||
|
|
|
|||
|
|
@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
|
|||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
PREDICATE: amd64-backend < x86-backend
|
||||
x86-backend-cell 8 = ;
|
||||
|
||||
M: amd64-backend ds-reg R14 ;
|
||||
M: amd64-backend rs-reg R15 ;
|
||||
M: amd64-backend stack-reg RSP ;
|
||||
M: amd64-backend xt-reg RCX ;
|
||||
M: amd64-backend stack-save-reg RSI ;
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
M: x86.64 xt-reg RCX ;
|
||||
M: x86.64 stack-save-reg RSI ;
|
||||
|
||||
M: temp-reg v>operand drop RBX ;
|
||||
|
||||
|
|
@ -34,18 +31,18 @@ M: float-regs vregs
|
|||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: amd64-backend address-operand ( address -- operand )
|
||||
M: x86.64 address-operand ( address -- operand )
|
||||
#! On AMD64, we have to load 64-bit addresses into a
|
||||
#! scratch register first. The usage of R11 here is a hack.
|
||||
#! This word can only be called right before a subroutine
|
||||
#! call, where all vregs have been flushed anyway.
|
||||
temp-reg v>operand [ swap MOV ] keep ;
|
||||
|
||||
M: amd64-backend fixnum>slot@ drop ;
|
||||
M: x86.64 fixnum>slot@ drop ;
|
||||
|
||||
M: amd64-backend prepare-division CQO ;
|
||||
M: x86.64 prepare-division CQO ;
|
||||
|
||||
M: amd64-backend load-indirect ( literal reg -- )
|
||||
M: x86.64 load-indirect ( literal reg -- )
|
||||
0 [] MOV rc-relative rel-literal ;
|
||||
|
||||
M: stack-params %load-param-reg
|
||||
|
|
@ -56,27 +53,27 @@ M: stack-params %load-param-reg
|
|||
M: stack-params %save-param-reg
|
||||
>r stack-frame* + cell + swap r> %load-param-reg ;
|
||||
|
||||
M: amd64-backend %prepare-unbox ( -- )
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
RDI R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
|
||||
M: amd64-backend %unbox ( n reg-class func -- )
|
||||
M: x86.64 %unbox ( n reg-class func -- )
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
! Store the return value on the C stack
|
||||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||
|
||||
M: amd64-backend %unbox-long-long ( n func -- )
|
||||
M: x86.64 %unbox-long-long ( n func -- )
|
||||
T{ int-regs } swap %unbox ;
|
||||
|
||||
M: amd64-backend %unbox-struct-1 ( -- )
|
||||
M: x86.64 %unbox-struct-1 ( -- )
|
||||
#! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
RAX RAX [] MOV ;
|
||||
|
||||
M: amd64-backend %unbox-struct-2 ( -- )
|
||||
M: x86.64 %unbox-struct-2 ( -- )
|
||||
#! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
|
|
@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
|
|||
! Load first cell
|
||||
RAX RAX [] MOV ;
|
||||
|
||||
M: amd64-backend %unbox-large-struct ( n size -- )
|
||||
M: x86.64 %unbox-large-struct ( n size -- )
|
||||
! Source is in RDI
|
||||
! Load destination address
|
||||
RSI RSP roll [+] LEA
|
||||
|
|
@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
|
|||
0 over param-reg swap return-reg
|
||||
2dup eq? [ 2drop ] [ MOV ] if ;
|
||||
|
||||
M: amd64-backend %box ( n reg-class func -- )
|
||||
M: x86.64 %box ( n reg-class func -- )
|
||||
rot [
|
||||
rot [ 0 swap param-reg ] keep %load-param-reg
|
||||
] [
|
||||
|
|
@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
|
|||
] if*
|
||||
f %alien-invoke ;
|
||||
|
||||
M: amd64-backend %box-long-long ( n func -- )
|
||||
M: x86.64 %box-long-long ( n func -- )
|
||||
T{ int-regs } swap %box ;
|
||||
|
||||
M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
|
||||
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
|
||||
|
||||
M: amd64-backend %box-small-struct ( size -- )
|
||||
M: x86.64 %box-small-struct ( size -- )
|
||||
#! Box a <= 16-byte struct returned in RAX:RDX.
|
||||
RDI RAX MOV
|
||||
RSI RDX MOV
|
||||
RDX swap MOV
|
||||
"box_small_struct" f %alien-invoke ;
|
||||
|
||||
M: amd64-backend %box-large-struct ( n size -- )
|
||||
M: x86.64 %box-large-struct ( n size -- )
|
||||
! Struct size is parameter 2
|
||||
RSI over MOV
|
||||
! Compute destination address
|
||||
|
|
@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
|
|||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: amd64-backend %prepare-box-struct ( size -- )
|
||||
M: x86.64 %prepare-box-struct ( size -- )
|
||||
! Compute target address for value struct return
|
||||
RAX RSP rot f struct-return@ [+] LEA
|
||||
RSP 0 [+] RAX MOV ;
|
||||
|
||||
M: amd64-backend %prepare-var-args RAX RAX XOR ;
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: amd64-backend %alien-invoke ( symbol dll -- )
|
||||
M: x86.64 %alien-invoke ( symbol dll -- )
|
||||
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
|
||||
|
||||
M: amd64-backend %prepare-alien-indirect ( -- )
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
cell temp@ RAX MOV ;
|
||||
|
||||
M: amd64-backend %alien-indirect ( -- )
|
||||
M: x86.64 %alien-indirect ( -- )
|
||||
cell temp@ CALL ;
|
||||
|
||||
M: amd64-backend %alien-callback ( quot -- )
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
RDI load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: amd64-backend %callback-value ( ctype -- )
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
! Put former top of data stack in RDI
|
||||
|
|
@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
|
|||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
M: amd64-backend %cleanup ( alien-node -- ) drop ;
|
||||
M: x86.64 %cleanup ( alien-node -- ) drop ;
|
||||
|
||||
M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
|
||||
M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
|
||||
|
||||
USE: cpu.x86.intrinsics
|
||||
|
||||
|
|
@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
|
|||
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||
\ set-alien-signed-4 small-reg-32 define-setter
|
||||
|
||||
T{ x86-backend f 8 } compiler-backend set-global
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ IN: cpu.x86.allot
|
|||
allot-reg swap tag-number OR
|
||||
allot-reg MOV ;
|
||||
|
||||
M: x86-backend %box-float ( dst src -- )
|
||||
M: x86 %box-float ( dst src -- )
|
||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||
#! dest is a loc or a vreg
|
||||
float 16 [
|
||||
|
|
@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: x86-backend %box-alien ( dst src -- )
|
||||
M: x86 %box-alien ( dst src -- )
|
||||
[
|
||||
{ "end" "f" } [ define-label ] each
|
||||
dup v>operand 0 CMP
|
||||
|
|
|
|||
|
|
@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
|
|||
generator.fixup system layouts combinators compiler.constants ;
|
||||
IN: cpu.x86.architecture
|
||||
|
||||
TUPLE: x86-backend cell ;
|
||||
|
||||
HOOK: ds-reg compiler-backend
|
||||
HOOK: rs-reg compiler-backend
|
||||
HOOK: stack-reg compiler-backend
|
||||
HOOK: xt-reg compiler-backend
|
||||
HOOK: stack-save-reg compiler-backend
|
||||
HOOK: ds-reg cpu
|
||||
HOOK: rs-reg cpu
|
||||
HOOK: stack-reg cpu
|
||||
HOOK: xt-reg cpu
|
||||
HOOK: stack-save-reg cpu
|
||||
|
||||
: stack@ stack-reg swap [+] ;
|
||||
|
||||
|
|
@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
|
|||
GENERIC: load-return-reg ( stack@ reg-class -- )
|
||||
GENERIC: store-return-reg ( stack@ reg-class -- )
|
||||
|
||||
HOOK: address-operand compiler-backend ( address -- operand )
|
||||
HOOK: address-operand cpu ( address -- operand )
|
||||
|
||||
HOOK: fixnum>slot@ compiler-backend
|
||||
HOOK: fixnum>slot@ cpu
|
||||
|
||||
HOOK: prepare-division compiler-backend
|
||||
HOOK: prepare-division cpu
|
||||
|
||||
M: immediate load-literal v>operand swap v>operand MOV ;
|
||||
|
||||
M: x86-backend stack-frame ( n -- i )
|
||||
M: x86 stack-frame ( n -- i )
|
||||
3 cells + 16 align cell - ;
|
||||
|
||||
M: x86-backend %save-word-xt ( -- )
|
||||
M: x86 %save-word-xt ( -- )
|
||||
xt-reg 0 MOV rc-absolute-cell rel-this ;
|
||||
|
||||
: factor-area-size 4 cells ;
|
||||
|
||||
M: x86-backend %prologue ( n -- )
|
||||
M: x86 %prologue ( n -- )
|
||||
dup cell + PUSH
|
||||
xt-reg PUSH
|
||||
stack-reg swap 2 cells - SUB ;
|
||||
|
||||
M: x86-backend %epilogue ( n -- )
|
||||
M: x86 %epilogue ( n -- )
|
||||
stack-reg swap ADD ;
|
||||
|
||||
: %alien-global ( symbol dll register -- )
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
|
||||
|
||||
M: x86-backend %prepare-alien-invoke
|
||||
M: x86 %prepare-alien-invoke
|
||||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
|
|
@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
|
|||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||
|
||||
M: x86-backend %call ( label -- ) CALL ;
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
|
||||
M: x86-backend %jump-label ( label -- ) JMP ;
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
|
||||
M: x86-backend %jump-t ( label -- )
|
||||
M: x86 %jump-t ( label -- )
|
||||
"flag" operand f v>operand CMP JNE ;
|
||||
|
||||
: code-alignment ( -- n )
|
||||
|
|
@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
|
|||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86-backend %dispatch ( -- )
|
||||
M: x86 %dispatch ( -- )
|
||||
[
|
||||
%epilogue-later
|
||||
! Load jump table base. We use a temporary register
|
||||
|
|
@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
|
|||
{ +clobber+ { "n" } }
|
||||
} with-template ;
|
||||
|
||||
M: x86-backend %dispatch-label ( word -- )
|
||||
M: x86 %dispatch-label ( word -- )
|
||||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
M: x86-backend %unbox-float ( dst src -- )
|
||||
M: x86 %unbox-float ( dst src -- )
|
||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
||||
|
||||
M: x86-backend %peek [ v>operand ] bi@ MOV ;
|
||||
M: x86 %peek [ v>operand ] bi@ MOV ;
|
||||
|
||||
M: x86-backend %replace swap %peek ;
|
||||
M: x86 %replace swap %peek ;
|
||||
|
||||
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||
|
||||
M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
|
||||
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
|
||||
|
||||
M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
|
||||
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
|
||||
|
||||
M: x86-backend fp-shadows-int? ( -- ? ) f ;
|
||||
M: x86 fp-shadows-int? ( -- ? ) f ;
|
||||
|
||||
M: x86-backend value-structs? t ;
|
||||
M: x86 value-structs? t ;
|
||||
|
||||
M: x86-backend small-enough? ( n -- ? )
|
||||
M: x86 small-enough? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
: %untag ( reg -- ) tag-mask get bitnot AND ;
|
||||
|
|
@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
|
|||
\ stack-frame get swap -
|
||||
] ?if ;
|
||||
|
||||
HOOK: %unbox-struct-1 compiler-backend ( -- )
|
||||
HOOK: %unbox-struct-1 cpu ( -- )
|
||||
|
||||
HOOK: %unbox-struct-2 compiler-backend ( -- )
|
||||
HOOK: %unbox-struct-2 cpu ( -- )
|
||||
|
||||
M: x86-backend %unbox-small-struct ( size -- )
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
||||
M: x86-backend struct-small-enough? ( size -- ? )
|
||||
M: x86 struct-small-enough? ( size -- ? )
|
||||
{ 1 2 4 8 } member?
|
||||
os { "linux" "netbsd" "solaris" } member? not and ;
|
||||
|
||||
M: x86-backend %return ( -- ) 0 %unwind ;
|
||||
M: x86 %return ( -- ) 0 %unwind ;
|
||||
|
||||
! Alien intrinsics
|
||||
M: x86-backend %unbox-byte-array ( dst src -- )
|
||||
M: x86 %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
||||
|
||||
M: x86-backend %unbox-alien ( dst src -- )
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||
|
||||
M: x86-backend %unbox-f ( dst src -- )
|
||||
M: x86 %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
|
||||
M: x86-backend %unbox-any-c-ptr ( dst src -- )
|
||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
! Address is computed in ds-reg
|
||||
ds-reg PUSH
|
||||
|
|
|
|||
|
|
@ -13,14 +13,14 @@ SINGLETON: x86.64
|
|||
SINGLETON: arm
|
||||
SINGLETON: ppc
|
||||
|
||||
UNION: x86 x86.32 x86.64 ;
|
||||
|
||||
: cpu ( -- class ) \ cpu get ;
|
||||
|
||||
! SINGLETON: winnt
|
||||
! SINGLETON: wince
|
||||
|
||||
! MIXIN: windows
|
||||
! INSTANCE: winnt windows
|
||||
! INSTANCE: wince windows
|
||||
! UNION: windows winnt wince ;
|
||||
|
||||
! SINGLETON: freebsd
|
||||
! SINGLETON: netbsd
|
||||
|
|
@ -29,11 +29,23 @@ SINGLETON: ppc
|
|||
! SINGLETON: macosx
|
||||
! SINGLETON: linux
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: string>cpu ( str -- class )
|
||||
H{
|
||||
{ "x86.32" x86.32 }
|
||||
{ "x86.64" x86.64 }
|
||||
{ "arm" arm }
|
||||
{ "ppc" ppc }
|
||||
} at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! : os ( -- class ) \ os get ;
|
||||
|
||||
[
|
||||
8 getenv "system" lookup \ cpu set-global
|
||||
! 9 getenv "system" lookup \ os set-global
|
||||
8 getenv string>cpu \ cpu set-global
|
||||
! 9 getenv string>os \ os set-global
|
||||
] "system" add-init-hook
|
||||
|
||||
: image ( -- path ) 13 getenv ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue