Reworking inline allocation codegen
Slava Pestov
parent
8fd119ede2
commit
6dde29e9c7
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs arrays generic kernel kernel.private
|
||||
math memory namespaces make sequences layouts system hashtables
|
||||
classes alien byte-arrays combinators words sets classes.algebra
|
||||
compiler.cfg.registers compiler.cfg.instructions ;
|
||||
classes alien byte-arrays combinators words ;
|
||||
IN: compiler.backend
|
||||
|
||||
! Labels
|
||||
|
|
@ -30,7 +29,7 @@ GENERIC: param-reg ( n register-class -- reg )
|
|||
M: object param-reg param-regs nth ;
|
||||
|
||||
! Load a literal (immediate or indirect)
|
||||
GENERIC# load-literal 1 ( obj vreg -- )
|
||||
GENERIC# load-literal 1 ( obj reg -- )
|
||||
|
||||
HOOK: load-indirect cpu ( obj reg -- )
|
||||
|
||||
|
|
@ -52,10 +51,10 @@ HOOK: %call cpu ( word -- )
|
|||
HOOK: %jump-label cpu ( label -- )
|
||||
|
||||
! Test if vreg is 'f' or not
|
||||
HOOK: %jump-f cpu ( label vreg -- )
|
||||
HOOK: %jump-f cpu ( label reg -- )
|
||||
|
||||
! Test if vreg is 't' or not
|
||||
HOOK: %jump-t cpu ( label vreg -- )
|
||||
HOOK: %jump-t cpu ( label reg -- )
|
||||
|
||||
HOOK: %dispatch cpu ( -- )
|
||||
|
||||
|
|
@ -71,10 +70,10 @@ HOOK: %inc-d cpu ( n -- )
|
|||
HOOK: %inc-r cpu ( n -- )
|
||||
|
||||
! Load stack into vreg
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
HOOK: %peek cpu ( reg loc -- )
|
||||
|
||||
! Store vreg to stack
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
HOOK: %replace cpu ( reg loc -- )
|
||||
|
||||
! Copy values between vregs
|
||||
HOOK: %copy cpu ( dst src -- )
|
||||
|
|
@ -148,21 +147,11 @@ M: stack-params param-reg drop ;
|
|||
|
||||
M: stack-params param-regs drop f ;
|
||||
|
||||
GENERIC: v>operand ( obj -- operand )
|
||||
|
||||
SYMBOL: registers
|
||||
|
||||
M: constant v>operand
|
||||
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
|
||||
M: value v>operand
|
||||
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
|
||||
|
||||
M: object load-literal v>operand load-indirect ;
|
||||
M: object load-literal load-indirect ;
|
||||
|
||||
PREDICATE: small-slot < integer cells small-enough? ;
|
||||
|
||||
PREDICATE: small-tagged < integer v>operand small-enough? ;
|
||||
PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
|
||||
|
||||
: if-small-struct ( n size true false -- ? )
|
||||
[ over not over struct-small-enough? and ] 2dip
|
||||
|
|
@ -194,30 +183,10 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
|||
|
||||
HOOK: %box-alien cpu ( dst src -- )
|
||||
|
||||
! Allocation
|
||||
HOOK: %allot cpu ( dst size type tag temp -- )
|
||||
|
||||
HOOK: %write-barrier cpu ( src temp -- )
|
||||
|
||||
! GC check
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
||||
SYMBOL: operands
|
||||
|
||||
: init-intrinsic ( insn -- )
|
||||
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
|
||||
|
||||
: (operand) ( name -- operand )
|
||||
operands get at* [ "Bad operand name" throw ] unless ;
|
||||
|
||||
: operand ( name -- operand )
|
||||
(operand) v>operand ;
|
||||
|
||||
: operand-class ( var -- class )
|
||||
(operand) value-class ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
>r [ operand ] map prune r> each ; inline
|
||||
|
|
|
|||
|
|
@ -2,27 +2,24 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.accessors arrays generic kernel system
|
||||
kernel.private math math.private memory namespaces sequences
|
||||
words math.floats.private layouts quotations cpu.x86
|
||||
compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
|
||||
compiler.constants compiler.backend compiler.backend.x86 ;
|
||||
words math.floats.private layouts quotations locals cpu.x86
|
||||
compiler.codegen compiler.cfg.templates compiler.cfg.builder
|
||||
compiler.cfg.registers compiler.constants compiler.backend
|
||||
compiler.backend.x86 ;
|
||||
IN: compiler.backend.x86.sse2
|
||||
|
||||
M: x86 %box-float ( dst src -- )
|
||||
M:: x86 %box-float ( dst src temp -- )
|
||||
#! Only called by pentium4 backend, uses SSE2 instruction
|
||||
#! dest is a loc or a vreg
|
||||
float 16 [
|
||||
8 (object@) swap v>operand MOVSD
|
||||
float %store-tagged
|
||||
] %allot ;
|
||||
dst 16 float float temp %allot
|
||||
dst 8 float tag-number - [+] src MOVSD ;
|
||||
|
||||
M: x86 %unbox-float ( dst src -- )
|
||||
[ v>operand ] bi@ float-offset [+] MOVSD ;
|
||||
float-offset [+] MOVSD ;
|
||||
|
||||
: define-float-op ( word op -- )
|
||||
[ "x" operand "y" operand ] swap suffix T{ template
|
||||
{ input { { float "x" } { float "y" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic ;
|
||||
|
||||
{
|
||||
|
|
@ -65,7 +62,6 @@ M: x86 %unbox-float ( dst src -- )
|
|||
{ scratch { { float "out" } } }
|
||||
{ output { "out" } }
|
||||
{ clobber { "in" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
: alien-float-get-template
|
||||
|
|
|
|||
|
|
@ -4,20 +4,12 @@ USING: accessors arrays byte-arrays alien.accessors
|
|||
compiler.backend kernel kernel.private math memory namespaces
|
||||
make sequences words system layouts combinators math.order
|
||||
math.private alien alien.c-types slots.private cpu.x86
|
||||
cpu.x86.private compiler.backend compiler.codegen.fixup
|
||||
cpu.x86.private locals compiler.backend compiler.codegen.fixup
|
||||
compiler.constants compiler.intrinsics compiler.cfg.builder
|
||||
compiler.cfg.registers compiler.cfg.stacks
|
||||
compiler.cfg.templates ;
|
||||
compiler.cfg.templates compiler.codegen ;
|
||||
IN: compiler.backend.x86
|
||||
|
||||
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: word JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: word CALL (CALL) rel-word ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: word JUMPcc (JUMPcc) rel-word ;
|
||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
||||
|
||||
HOOK: ds-reg cpu ( -- reg )
|
||||
HOOK: rs-reg cpu ( -- reg )
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
|
@ -27,8 +19,10 @@ HOOK: stack-save-reg cpu ( -- reg )
|
|||
|
||||
: reg-stack ( n reg -- op ) swap cells neg [+] ;
|
||||
|
||||
M: ds-loc v>operand n>> ds-reg reg-stack ;
|
||||
M: rs-loc v>operand n>> rs-reg reg-stack ;
|
||||
GENERIC: loc>operand ( loc -- operand )
|
||||
|
||||
M: ds-loc loc>operand n>> ds-reg reg-stack ;
|
||||
M: rs-loc loc>operand n>> rs-reg reg-stack ;
|
||||
|
||||
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
|
||||
M: int-regs %load-param-reg drop swap stack@ MOV ;
|
||||
|
|
@ -54,10 +48,10 @@ HOOK: fixnum>slot@ cpu ( op -- )
|
|||
HOOK: prepare-division cpu ( -- )
|
||||
|
||||
M: f load-literal
|
||||
v>operand \ f tag-number MOV drop ;
|
||||
\ f tag-number MOV drop ;
|
||||
|
||||
M: fixnum load-literal
|
||||
v>operand swap tag-fixnum MOV ;
|
||||
swap tag-fixnum MOV ;
|
||||
|
||||
M: x86 stack-frame ( n -- i )
|
||||
3 cells + 16 align cell - ;
|
||||
|
|
@ -99,16 +93,16 @@ M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
|
|||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86 %dispatch ( -- )
|
||||
M:: x86 %dispatch ( src temp -- )
|
||||
! Load jump table base. We use a temporary register
|
||||
! since on AMD64 we have to load a 64-bit immediate. On
|
||||
! x86, this is redundant.
|
||||
! Untag and multiply to get a jump table offset
|
||||
temp-reg-1 fixnum>slot@
|
||||
src fixnum>slot@
|
||||
! Add jump table base
|
||||
temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
temp-reg-1 temp-reg-2 ADD
|
||||
temp-reg-1 HEX: 7f [+] JMP
|
||||
temp HEX: ffffffff MOV rc-absolute-cell rel-here
|
||||
src temp ADD
|
||||
src HEX: 7f [+] JMP
|
||||
! Fix up the displacement above
|
||||
code-alignment dup bootstrap-cell 8 = 15 9 ? +
|
||||
building get dup pop* push
|
||||
|
|
@ -117,9 +111,9 @@ M: x86 %dispatch ( -- )
|
|||
M: x86 %dispatch-label ( word -- )
|
||||
0 cell, rc-absolute-cell rel-word ;
|
||||
|
||||
M: x86 %peek [ v>operand ] bi@ MOV ;
|
||||
M: x86 %peek loc>operand MOV ;
|
||||
|
||||
M: x86 %replace swap %peek ;
|
||||
M: x86 %replace loc>operand swap MOV ;
|
||||
|
||||
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
|
||||
|
||||
|
|
@ -146,13 +140,13 @@ M: x86 %return ( -- ) 0 %unwind ;
|
|||
|
||||
! Alien intrinsics
|
||||
M: x86 %unbox-byte-array ( dst src -- )
|
||||
[ v>operand ] bi@ byte-array-offset [+] LEA ;
|
||||
byte-array-offset [+] LEA ;
|
||||
|
||||
M: x86 %unbox-alien ( dst src -- )
|
||||
[ v>operand ] bi@ alien-offset [+] MOV ;
|
||||
alien-offset [+] MOV ;
|
||||
|
||||
M: x86 %unbox-f ( dst src -- )
|
||||
drop v>operand 0 MOV ;
|
||||
drop 0 MOV ;
|
||||
|
||||
M: x86 %unbox-any-c-ptr ( dst src -- )
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
|
|
@ -161,7 +155,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
|||
ds-reg 0 MOV
|
||||
! Object is stored in ds-reg
|
||||
rs-reg PUSH
|
||||
rs-reg swap v>operand MOV
|
||||
rs-reg swap MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
|
|
@ -182,34 +176,45 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
|
|||
ds-reg byte-array-offset ADD
|
||||
"end" resolve-label
|
||||
! Done, store address in destination register
|
||||
v>operand ds-reg MOV
|
||||
ds-reg MOV
|
||||
! Restore rs-reg
|
||||
rs-reg POP
|
||||
! Restore ds-reg
|
||||
ds-reg POP ;
|
||||
|
||||
: allot-reg ( -- reg )
|
||||
#! We temporarily use the datastack register, since it won't
|
||||
#! be accessed inside the quotation given to %allot in any
|
||||
#! case.
|
||||
ds-reg ;
|
||||
M:: x86 %write-barrier ( src temp -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
src card-bits SHR
|
||||
"cards_offset" f temp %alien-global
|
||||
temp temp [+] card-mark <byte> MOV
|
||||
|
||||
: (object@) ( n -- operand ) allot-reg swap [+] ;
|
||||
|
||||
: object@ ( n -- operand ) cells (object@) ;
|
||||
! Mark the card deck
|
||||
temp deck-bits card-bits - SHR
|
||||
"decks_offset" f temp %alien-global
|
||||
temp temp [+] card-mark <byte> MOV ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
#! Load pointer to start of zone array
|
||||
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
|
||||
|
||||
: load-allot-ptr ( -- )
|
||||
allot-reg load-zone-ptr
|
||||
allot-reg PUSH
|
||||
allot-reg dup cell [+] MOV ;
|
||||
: load-allot-ptr ( temp -- )
|
||||
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
|
||||
|
||||
: inc-allot-ptr ( n -- )
|
||||
allot-reg POP
|
||||
allot-reg cell [+] swap 8 align ADD ;
|
||||
: inc-allot-ptr ( n temp -- )
|
||||
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
|
||||
|
||||
: store-header ( temp type -- )
|
||||
[ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst temp tag -- )
|
||||
dupd tag-number OR MOV ;
|
||||
|
||||
M:: x86 %allot ( dst size type tag temp -- )
|
||||
temp load-allot-ptr
|
||||
temp type store-header
|
||||
temp size inc-allot-ptr
|
||||
dst temp store-tagged ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
"end" define-label
|
||||
|
|
@ -223,73 +228,53 @@ M: x86 %gc ( -- )
|
|||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
: store-header ( header -- )
|
||||
0 object@ swap type-number tag-fixnum MOV ;
|
||||
: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
|
||||
|
||||
: %allot ( header size quot -- )
|
||||
allot-reg PUSH
|
||||
swap >r >r
|
||||
load-allot-ptr
|
||||
store-header
|
||||
r> call
|
||||
r> inc-allot-ptr
|
||||
allot-reg POP ; inline
|
||||
|
||||
: fresh-object drop ;
|
||||
|
||||
: %store-tagged ( reg tag -- )
|
||||
>r dup fresh-object v>operand r>
|
||||
allot-reg swap tag-number OR
|
||||
allot-reg MOV ;
|
||||
|
||||
: %allot-bignum-signed-1 ( outreg inreg -- )
|
||||
:: %allot-bignum-signed-1 ( dst src temp -- )
|
||||
#! on entry, inreg is a signed 32-bit quantity
|
||||
#! exits with tagged ptr to bignum in outreg
|
||||
#! 1 cell header, 1 cell length, 1 cell sign, + digits
|
||||
#! length is the # of digits + sign
|
||||
[
|
||||
{ "end" "nonzero" "positive" "store" }
|
||||
[ define-label ] each
|
||||
dup v>operand 0 CMP ! is it zero?
|
||||
{ "end" "nonzero" "positive" "store" } [ define-label ] each
|
||||
src 0 CMP ! is it zero?
|
||||
"nonzero" get JNE
|
||||
0 >bignum pick v>operand load-indirect ! this is our result
|
||||
! Use cached zero value
|
||||
0 >bignum dst load-indirect
|
||||
"end" get JMP
|
||||
"nonzero" resolve-label
|
||||
bignum 4 cells [
|
||||
! Write length
|
||||
1 object@ 2 v>operand MOV
|
||||
! Test sign
|
||||
dup v>operand 0 CMP
|
||||
"positive" get JGE
|
||||
2 object@ 1 MOV ! negative sign
|
||||
dup v>operand NEG
|
||||
"store" get JMP
|
||||
"positive" resolve-label
|
||||
2 object@ 0 MOV ! positive sign
|
||||
"store" resolve-label
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in reg
|
||||
bignum %store-tagged
|
||||
] %allot
|
||||
! Allocate a bignum
|
||||
dst 4 cells bignum bignum temp %allot
|
||||
! Write length
|
||||
dst 1 bignum@ 2 MOV
|
||||
! Test sign
|
||||
src 0 CMP
|
||||
"positive" get JGE
|
||||
dst 2 bignum@ 1 MOV ! negative sign
|
||||
src NEG
|
||||
"store" get JMP
|
||||
"positive" resolve-label
|
||||
dst 2 bignum@ 0 MOV ! positive sign
|
||||
"store" resolve-label
|
||||
dst 3 bignum@ src MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: x86 %box-alien ( dst src -- )
|
||||
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
||||
|
||||
M:: x86 %box-alien ( dst src temp -- )
|
||||
[
|
||||
{ "end" "f" } [ define-label ] each
|
||||
dup v>operand 0 CMP
|
||||
src 0 CMP
|
||||
"f" get JE
|
||||
alien 4 cells [
|
||||
1 object@ \ f tag-number MOV
|
||||
2 object@ \ f tag-number MOV
|
||||
! Store src in alien-offset slot
|
||||
3 object@ swap v>operand MOV
|
||||
! Store tagged ptr in dst
|
||||
dup object %store-tagged
|
||||
] %allot
|
||||
dst 4 cells alien object temp %allot
|
||||
dst 1 alien@ \ f tag-number MOV
|
||||
dst 2 alien@ \ f tag-number MOV
|
||||
! Store src in alien-offset slot
|
||||
dst 3 alien@ src MOV
|
||||
"end" get JMP
|
||||
"f" resolve-label
|
||||
f [ v>operand ] bi@ MOV
|
||||
\ f tag-number MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -321,7 +306,7 @@ M: x86 %box-alien ( dst src -- )
|
|||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ "val" operand %slot-literal-known-tag MOV ] T{ template
|
||||
{ input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
{ input { { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "val" } } }
|
||||
{ output { "val" } }
|
||||
}
|
||||
|
|
@ -329,7 +314,7 @@ M: x86 %box-alien ( dst src -- )
|
|||
! Slot number is literal
|
||||
{
|
||||
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
|
||||
{ input { { f "obj" } { [ small-slot? ] "n" } } }
|
||||
{ input { { f "obj" } { small-slot "n" } } }
|
||||
{ output { "obj" } }
|
||||
}
|
||||
}
|
||||
|
|
@ -343,40 +328,26 @@ M: x86 %box-alien ( dst src -- )
|
|||
}
|
||||
} define-intrinsics
|
||||
|
||||
: generate-write-barrier ( -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
"val" operand-immediate? "obj" fresh-object? or [
|
||||
! Mark the card
|
||||
"obj" operand card-bits SHR
|
||||
"cards_offset" f "scratch" operand %alien-global
|
||||
"scratch" operand "obj" operand [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
"obj" operand deck-bits card-bits - SHR
|
||||
"decks_offset" f "scratch" operand %alien-global
|
||||
"scratch" operand "obj" operand [+] card-mark <byte> MOV
|
||||
] unless ;
|
||||
|
||||
\ set-slot {
|
||||
\ (set-slot) {
|
||||
! Slot number is literal and the tag is known
|
||||
{
|
||||
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
|
||||
{ input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
|
||||
[ %slot-literal-known-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number is literal
|
||||
{
|
||||
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
|
||||
[ %slot-literal-any-tag "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { small-slot "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" } }
|
||||
}
|
||||
}
|
||||
! Slot number in a register
|
||||
{
|
||||
[ %slot-any "val" operand MOV generate-write-barrier ] T{ template
|
||||
[ %slot-any "val" operand MOV ] T{ template
|
||||
{ input { { f "val" } { f "obj" } { f "n" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ clobber { "obj" "n" } }
|
||||
|
|
@ -400,7 +371,7 @@ M: x86 %box-alien ( dst src -- )
|
|||
|
||||
: fixnum-value-op ( op -- pair )
|
||||
T{ template
|
||||
{ input { { f "x" } { [ small-tagged? ] "y" } } }
|
||||
{ input { { f "x" } { small-tagged "y" } } }
|
||||
{ output { "x" } }
|
||||
} fixnum-op ;
|
||||
|
||||
|
|
@ -476,7 +447,7 @@ M: x86 %box-alien ( dst src -- )
|
|||
! There was an overflow. Recompute the original operand.
|
||||
{ "y" "x" } %untag-fixnums
|
||||
"x" operand "y" operand rot execute
|
||||
"z" get "x" get %allot-bignum-signed-1
|
||||
"z" operand "x" operand "y" operand %allot-bignum-signed-1
|
||||
"end" resolve-label ; inline
|
||||
|
||||
: overflow-template ( word insn -- )
|
||||
|
|
@ -516,9 +487,10 @@ M: x86 %box-alien ( dst src -- )
|
|||
|
||||
\ fixnum>bignum [
|
||||
"x" operand %untag-fixnum
|
||||
"x" get dup %allot-bignum-signed-1
|
||||
"x" operand dup "scratch" operand %allot-bignum-signed-1
|
||||
] T{ template
|
||||
{ input { { f "x" } } }
|
||||
{ scratch { { f "scratch" } } }
|
||||
{ output { "x" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
|
@ -531,7 +503,7 @@ M: x86 %box-alien ( dst src -- )
|
|||
"y" operand "x" operand cell [+] MOV
|
||||
! if the length is 1, its just the sign and nothing else,
|
||||
! so output 0
|
||||
"y" operand 1 v>operand CMP
|
||||
"y" operand 1 tag-fixnum CMP
|
||||
"nonzero" get JNE
|
||||
"y" operand 0 MOV
|
||||
"end" get JMP
|
||||
|
|
@ -577,90 +549,6 @@ M: x86 %box-alien ( dst src -- )
|
|||
{ clobber { "n" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ (tuple) [
|
||||
tuple "layout" get size>> 2 + cells [
|
||||
! Store layout
|
||||
"layout" get "scratch" operand load-indirect
|
||||
1 object@ "scratch" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"tuple" get tuple %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "layout" } } }
|
||||
{ scratch { { f "tuple" } { f "scratch" } } }
|
||||
{ output { "tuple" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ (array) [
|
||||
array "n" get 2 + cells [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "n" } } }
|
||||
{ scratch { { f "array" } } }
|
||||
{ output { "array" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ (byte-array) [
|
||||
byte-array "n" get 2 cells + [
|
||||
! Store length
|
||||
1 object@ "n" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"array" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { [ ] "n" } } }
|
||||
{ scratch { { f "array" } } }
|
||||
{ output { "array" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <ratio> [
|
||||
ratio 3 cells [
|
||||
1 object@ "numerator" operand MOV
|
||||
2 object@ "denominator" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"ratio" get ratio %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "numerator" } { f "denominator" } } }
|
||||
{ scratch { { f "ratio" } } }
|
||||
{ output { "ratio" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <complex> [
|
||||
complex 3 cells [
|
||||
1 object@ "real" operand MOV
|
||||
2 object@ "imaginary" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"complex" get complex %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "real" } { f "imaginary" } } }
|
||||
{ scratch { { f "complex" } } }
|
||||
{ output { "complex" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
\ <wrapper> [
|
||||
wrapper 2 cells [
|
||||
1 object@ "obj" operand MOV
|
||||
! Store tagged ptr in reg
|
||||
"wrapper" get object %store-tagged
|
||||
] %allot
|
||||
] T{ template
|
||||
{ input { { f "obj" } } }
|
||||
{ scratch { { f "wrapper" } } }
|
||||
{ output { "wrapper" } }
|
||||
{ gc t }
|
||||
} define-intrinsic
|
||||
|
||||
! Alien intrinsics
|
||||
: %alien-accessor ( quot -- )
|
||||
"offset" operand %untag-fixnum
|
||||
|
|
|
|||
|
|
@ -1,7 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators hashtables kernel
|
||||
math fry namespaces make sequences words stack-checker.inlining
|
||||
math fry namespaces make sequences words byte-arrays
|
||||
locals layouts
|
||||
stack-checker.inlining
|
||||
compiler.intrinsics
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.combinators
|
||||
|
|
@ -142,8 +145,7 @@ M: #recursive emit-node
|
|||
children>> [ emit-nodes ] emit-branches ;
|
||||
|
||||
M: #if emit-node
|
||||
{ { f "flag" } } lazy-load first ##branch-t
|
||||
emit-if iterate-next ;
|
||||
phantom-pop ##branch-t emit-if iterate-next ;
|
||||
|
||||
! #dispatch
|
||||
: dispatch-branch ( nodes word -- label )
|
||||
|
|
@ -167,7 +169,9 @@ M: #if emit-node
|
|||
] each ;
|
||||
|
||||
: emit-dispatch ( node -- )
|
||||
##epilogue ##dispatch dispatch-branches init-phantoms ;
|
||||
phantom-pop int-regs next-vreg
|
||||
[ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
|
||||
dispatch-branches init-phantoms ;
|
||||
|
||||
M: #dispatch emit-node
|
||||
tail-call? [
|
||||
|
|
@ -225,12 +229,45 @@ M: #dispatch emit-node
|
|||
: setup-value-classes ( #call -- )
|
||||
node-input-infos [ class>> ] map set-value-classes ;
|
||||
|
||||
{
|
||||
(tuple) (array) (byte-array)
|
||||
(complex) (ratio) (wrapper)
|
||||
(write-barrier)
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
: allot-size ( #call -- n )
|
||||
1 phantom-datastack get phantom-input first value>> ;
|
||||
|
||||
:: emit-allot ( size type tag -- )
|
||||
int-regs next-vreg
|
||||
dup fresh-object
|
||||
dup size type tag int-regs next-vreg ##allot
|
||||
type tagged boa phantom-push ;
|
||||
|
||||
: emit-write-barrier ( -- )
|
||||
phantom-pop dup >vreg fresh-object? [ drop ] [
|
||||
int-regs next-vreg ##write-barrier
|
||||
] if ;
|
||||
|
||||
: emit-intrinsic ( word -- next )
|
||||
{
|
||||
{ \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
|
||||
{ \ (array) [ allot-size 2 cells + array object emit-allot ] }
|
||||
{ \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
|
||||
{ \ (complex) [ 3 cells complex complex emit-allot ] }
|
||||
{ \ (ratio) [ 3 cells ratio ratio emit-allot ] }
|
||||
{ \ (wrapper) [ 2 cells wrapper object emit-allot ] }
|
||||
{ \ (write-barrier) [ emit-write-barrier ] }
|
||||
} case
|
||||
iterate-next ;
|
||||
|
||||
M: #call emit-node
|
||||
dup setup-value-classes
|
||||
dup find-if-intrinsic [ do-if-intrinsic ] [
|
||||
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
|
||||
dup find-intrinsic [ do-intrinsic ] [
|
||||
word>> emit-call
|
||||
word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic ] [ emit-call ] if
|
||||
] ?if
|
||||
] ?if
|
||||
] ?if ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ INSN: ##intrinsic quot defs-vregs uses-vregs ;
|
|||
|
||||
! Jump tables
|
||||
INSN: ##dispatch-label label ;
|
||||
INSN: ##dispatch ;
|
||||
INSN: ##dispatch src temp ;
|
||||
|
||||
! Boxing and unboxing
|
||||
INSN: ##copy < ##unary ;
|
||||
|
|
@ -37,9 +37,12 @@ INSN: ##unbox-f < ##unary ;
|
|||
INSN: ##unbox-alien < ##unary ;
|
||||
INSN: ##unbox-byte-array < ##unary ;
|
||||
INSN: ##unbox-any-c-ptr < ##unary ;
|
||||
INSN: ##box-float < ##unary ;
|
||||
INSN: ##box-alien < ##unary ;
|
||||
INSN: ##box-float < ##unary temp ;
|
||||
INSN: ##box-alien < ##unary temp ;
|
||||
|
||||
! Memory allocation
|
||||
INSN: ##allot < ##nullary size type tag temp ;
|
||||
INSN: ##write-barrier src temp ;
|
||||
INSN: ##gc ;
|
||||
|
||||
! FFI
|
||||
|
|
@ -52,10 +55,21 @@ GENERIC: uses-vregs ( insn -- seq )
|
|||
|
||||
M: ##nullary defs-vregs dst>> >vreg 1array ;
|
||||
M: ##unary defs-vregs dst>> >vreg 1array ;
|
||||
M: ##write-barrier defs-vregs temp>> >vreg 1array ;
|
||||
|
||||
: allot-defs-vregs ( insn -- seq )
|
||||
[ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
|
||||
|
||||
M: ##box-float defs-vregs allot-defs-vregs ;
|
||||
M: ##box-alien defs-vregs allot-defs-vregs ;
|
||||
M: ##allot defs-vregs allot-defs-vregs ;
|
||||
M: ##dispatch defs-vregs temp>> >vreg 1array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
M: ##replace uses-vregs src>> >vreg 1array ;
|
||||
M: ##unary uses-vregs src>> >vreg 1array ;
|
||||
M: ##write-barrier uses-vregs src>> >vreg 1array ;
|
||||
M: ##dispatch uses-vregs src>> >vreg 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
||||
: intrinsic-vregs ( assoc -- seq' )
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ SYMBOL: live-intervals
|
|||
at [ (>>end) ] [ uses>> push ] 2bi ;
|
||||
|
||||
: new-live-interval ( n vreg live-intervals -- )
|
||||
2dup key? [ "Multiple defs" throw ] when
|
||||
[ [ <live-interval> ] keep ] dip set-at ;
|
||||
|
||||
: compute-live-intervals* ( insn n -- )
|
||||
|
|
|
|||
|
|
@ -3,18 +3,12 @@
|
|||
USING: arrays assocs classes classes.private classes.algebra
|
||||
combinators hashtables kernel layouts math fry namespaces
|
||||
quotations sequences system vectors words effects alien
|
||||
byte-arrays accessors sets math.order compiler.cfg.instructions
|
||||
compiler.cfg.registers ;
|
||||
byte-arrays accessors sets math.order compiler.backend
|
||||
compiler.cfg.instructions compiler.cfg.registers ;
|
||||
IN: compiler.cfg.stacks
|
||||
|
||||
! Converting stack operations into register operations, while
|
||||
! doing a bit of optimization along the way.
|
||||
|
||||
USE: qualified
|
||||
FROM: compiler.generator.registers => +input+ ;
|
||||
FROM: compiler.generator.registers => +output+ ;
|
||||
FROM: compiler.generator.registers => +scratch+ ;
|
||||
FROM: compiler.generator.registers => +clobber+ ;
|
||||
SYMBOL: known-tag
|
||||
|
||||
! Value protocol
|
||||
|
|
@ -100,6 +94,14 @@ M: constant move-spec class ;
|
|||
swap >>class
|
||||
%move ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
: fresh-object ( vreg/t -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
|
||||
|
||||
: %move ( dst src -- )
|
||||
2dup [ move-spec ] bi@ 2array {
|
||||
{ { f f } [ ##copy ] }
|
||||
|
|
@ -114,8 +116,8 @@ M: constant move-spec class ;
|
|||
|
||||
{ { f constant } [ value>> ##load-literal ] }
|
||||
|
||||
{ { f float } [ ##box-float ] }
|
||||
{ { f unboxed-alien } [ ##box-alien ] }
|
||||
{ { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
|
||||
{ { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
|
||||
{ { f loc } [ ##peek ] }
|
||||
|
||||
{ { float f } [ ##unbox-float ] }
|
||||
|
|
@ -223,10 +225,6 @@ M: phantom-retainstack finalize-height
|
|||
: live-locs ( -- seq )
|
||||
[ (live-locs) ] each-phantom append prune ;
|
||||
|
||||
! Operands holding pointers to freshly-allocated objects which
|
||||
! are guaranteed to be in the nursery
|
||||
SYMBOL: fresh-objects
|
||||
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq? double-float-regs int-regs ? ;
|
||||
|
||||
|
|
@ -255,7 +253,7 @@ SYMBOL: fresh-objects
|
|||
|
||||
M: value (lazy-load)
|
||||
{
|
||||
{ [ dup quotation? ] [ drop ] }
|
||||
{ [ dup { small-slot small-tagged } memq? ] [ drop ] }
|
||||
{ [ 2dup compatible? ] [ drop ] }
|
||||
[ (eager-load) ]
|
||||
} cond ;
|
||||
|
|
@ -280,23 +278,11 @@ M: loc lazy-store
|
|||
dup loc? over cached? or [ 2drop ] [ %move ] if
|
||||
] each-loc ;
|
||||
|
||||
: reset-phantom ( phantom -- )
|
||||
#! Kill register assignments but preserve constants and
|
||||
#! class information.
|
||||
dup phantom-locs*
|
||||
over stack>> [
|
||||
dup constant? [ nip ] [
|
||||
value-class over set-value-class
|
||||
] if
|
||||
] 2map
|
||||
over stack>> delete-all
|
||||
swap stack>> push-all ;
|
||||
|
||||
: reset-phantoms ( -- )
|
||||
[ reset-phantom ] each-phantom ;
|
||||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
||||
: finalize-contents ( -- )
|
||||
finalize-locs finalize-vregs reset-phantoms ;
|
||||
finalize-locs finalize-vregs clear-phantoms ;
|
||||
|
||||
! Loading stacks to vregs
|
||||
: vreg-substitution ( value vreg -- pair )
|
||||
|
|
@ -312,26 +298,22 @@ M: loc lazy-store
|
|||
[ substitute-vreg? ] assoc-filter >hashtable
|
||||
'[ stack>> _ substitute-here ] each-phantom ;
|
||||
|
||||
: clear-phantoms ( -- )
|
||||
[ stack>> delete-all ] each-phantom ;
|
||||
|
||||
: set-value-classes ( classes -- )
|
||||
phantom-datastack get
|
||||
over length over add-locs
|
||||
stack>> [ set-value-class ] 2reverse-each ;
|
||||
stack>> [
|
||||
[ value-class class-and ] keep set-value-class
|
||||
] 2reverse-each ;
|
||||
|
||||
: finalize-phantoms ( -- )
|
||||
#! Commit all deferred stacking shuffling, and ensure the
|
||||
#! in-memory data and retain stacks are up to date with
|
||||
#! respect to the compiler's current picture.
|
||||
finalize-contents
|
||||
clear-phantoms
|
||||
finalize-heights
|
||||
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
|
||||
|
||||
: fresh-object ( obj -- ) fresh-objects get push ;
|
||||
|
||||
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
|
||||
fresh-objects get [
|
||||
empty? [ 0 ##frame-required ##gc ] unless
|
||||
] [ delete-all ] bi ;
|
||||
|
||||
: init-phantoms ( -- )
|
||||
V{ } clone fresh-objects set
|
||||
|
|
@ -364,3 +346,7 @@ M: loc lazy-store
|
|||
|
||||
: phantom-rdrop ( n -- )
|
||||
phantom-retainstack get phantom-input drop ;
|
||||
|
||||
: phantom-pop ( -- vreg )
|
||||
1 phantom-datastack get phantom-input dup first f (lazy-load)
|
||||
[ 1array substitute-vregs ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs accessors sequences kernel fry namespaces
|
||||
quotations combinators classes.algebra compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stacks ;
|
||||
quotations combinators classes.algebra compiler.backend
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
|
||||
IN: compiler.cfg.templates
|
||||
|
||||
TUPLE: template input output scratch clobber gc ;
|
||||
|
|
@ -57,7 +57,9 @@ TUPLE: template input output scratch clobber gc ;
|
|||
|
||||
: apply-template ( pair quot -- vregs )
|
||||
[
|
||||
first2 dup do-template-inputs
|
||||
first2
|
||||
dup gc>> [ t fresh-object ] when
|
||||
dup do-template-inputs
|
||||
[ do-template-outputs ] 2keep
|
||||
] dip call ; inline
|
||||
|
||||
|
|
@ -67,12 +69,11 @@ TUPLE: template input output scratch clobber gc ;
|
|||
#! to the fixnum. Otherwise, the values don't match. If the
|
||||
#! spec is not a quotation, its a reg-class, in which case
|
||||
#! the value is always good.
|
||||
dup quotation? [
|
||||
over constant?
|
||||
[ >r value>> r> 2drop f ] [ 2drop f ] if
|
||||
] [
|
||||
2drop t
|
||||
] if ;
|
||||
{
|
||||
{ [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
|
||||
{ [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
: class-matches? ( actual expected -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make math math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
threads continuations.private libc combinators
|
||||
alien alien.c-types alien.structs alien.strings
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings sets threads libc continuations.private
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.backend
|
||||
|
|
@ -15,6 +15,16 @@ IN: compiler.codegen
|
|||
|
||||
GENERIC: generate-insn ( insn -- )
|
||||
|
||||
GENERIC: v>operand ( obj -- operand )
|
||||
|
||||
SYMBOL: registers
|
||||
|
||||
M: constant v>operand
|
||||
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
|
||||
M: value v>operand
|
||||
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
|
||||
|
||||
: generate-insns ( insns -- code )
|
||||
[
|
||||
[
|
||||
|
|
@ -66,11 +76,14 @@ M: _prologue generate-insn
|
|||
M: _epilogue generate-insn
|
||||
n>> %epilogue ;
|
||||
|
||||
M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
|
||||
M: ##load-literal generate-insn
|
||||
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
|
||||
|
||||
M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
|
||||
M: ##peek generate-insn
|
||||
[ dst>> v>operand ] [ loc>> ] bi %peek ;
|
||||
|
||||
M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
|
||||
M: ##replace generate-insn
|
||||
[ src>> ] [ loc>> ] bi %replace ;
|
||||
|
||||
M: ##inc-d generate-insn n>> %inc-d ;
|
||||
|
||||
|
|
@ -82,9 +95,32 @@ M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
|
|||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
|
||||
SYMBOL: operands
|
||||
|
||||
: init-intrinsic ( insn -- )
|
||||
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
|
||||
|
||||
M: ##intrinsic generate-insn
|
||||
[ init-intrinsic ] [ quot>> call ] bi ;
|
||||
|
||||
: (operand) ( name -- operand )
|
||||
operands get at* [ "Bad operand name" throw ] unless ;
|
||||
|
||||
: operand ( name -- operand )
|
||||
(operand) v>operand ;
|
||||
|
||||
: operand-class ( var -- class )
|
||||
(operand) value-class ;
|
||||
|
||||
: operand-tag ( operand -- tag/f )
|
||||
operand-class dup [ class-tag ] when ;
|
||||
|
||||
: operand-immediate? ( operand -- ? )
|
||||
operand-class immediate class<= ;
|
||||
|
||||
: unique-operands ( operands quot -- )
|
||||
>r [ operand ] map prune r> each ; inline
|
||||
|
||||
M: _if-intrinsic generate-insn
|
||||
[ init-intrinsic ]
|
||||
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
|
||||
|
|
@ -93,32 +129,48 @@ M: _branch generate-insn
|
|||
label>> lookup-label %jump-label ;
|
||||
|
||||
M: _branch-f generate-insn
|
||||
[ src>> ] [ label>> lookup-label ] bi %jump-f ;
|
||||
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
|
||||
|
||||
M: _branch-t generate-insn
|
||||
[ src>> ] [ label>> lookup-label ] bi %jump-t ;
|
||||
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
|
||||
|
||||
M: ##dispatch-label generate-insn label>> %dispatch-label ;
|
||||
|
||||
M: ##dispatch generate-insn drop %dispatch ;
|
||||
|
||||
M: ##copy generate-insn %copy ;
|
||||
: dst/src ( insn -- dst src )
|
||||
[ dst>> v>operand ] [ src>> v>operand ] bi ;
|
||||
|
||||
M: ##copy-float generate-insn %copy-float ;
|
||||
M: ##copy generate-insn dst/src %copy ;
|
||||
|
||||
M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
|
||||
M: ##copy-float generate-insn dst/src %copy-float ;
|
||||
|
||||
M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
|
||||
M: ##unbox-float generate-insn dst/src %unbox-float ;
|
||||
|
||||
M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
|
||||
M: ##unbox-f generate-insn dst/src %unbox-f ;
|
||||
|
||||
M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
|
||||
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
|
||||
|
||||
M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
|
||||
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
|
||||
|
||||
M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
|
||||
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
|
||||
|
||||
M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
|
||||
M: ##box-float generate-insn dst/src %box-float ;
|
||||
|
||||
M: ##box-alien generate-insn dst/src %box-alien ;
|
||||
|
||||
M: ##allot generate-insn
|
||||
{
|
||||
[ dst>> v>operand ]
|
||||
[ size>> ]
|
||||
[ type>> ]
|
||||
[ tag>> ]
|
||||
[ temp>> v>operand ]
|
||||
} cleave
|
||||
%allot ;
|
||||
|
||||
M: ##write-barrier generate-insn
|
||||
[ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
|
||||
|
||||
M: ##gc generate-insn drop %gc ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue