compiler.cfg: Change low-level IR constructors from ##foo to <##foo>
parent
d65bd97a54
commit
eb2a0c611b
|
@ -112,7 +112,7 @@ M: #alien-invoke emit-node
|
|||
[ caller-stack-frame ]
|
||||
[ caller-linkage ]
|
||||
} cleave
|
||||
<gc-map> ##alien-invoke
|
||||
<gc-map> <##alien-invoke>
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
|
@ -124,7 +124,7 @@ M: #alien-indirect emit-node ( node -- )
|
|||
[ caller-parameters ]
|
||||
[ prepare-caller-return ]
|
||||
[ caller-stack-frame ] tri
|
||||
<gc-map> ##alien-indirect
|
||||
<gc-map> <##alien-indirect>
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
|
@ -137,7 +137,7 @@ M: #alien-assembly emit-node
|
|||
[ prepare-caller-return ]
|
||||
[ caller-stack-frame ]
|
||||
[ quot>> ]
|
||||
} cleave <gc-map> ##alien-assembly
|
||||
} cleave <gc-map> <##alien-assembly>
|
||||
]
|
||||
[ caller-return ]
|
||||
bi ;
|
||||
|
@ -183,7 +183,7 @@ M: #alien-assembly emit-node
|
|||
[ last #return? t assert= ] [ but-last emit-nodes ] bi ;
|
||||
|
||||
: emit-callback-return ( params -- )
|
||||
basic-block get [ callee-return ##callback-outputs ] [ drop ] if ;
|
||||
basic-block get [ callee-return <##callback-outputs> ] [ drop ] if ;
|
||||
|
||||
M: #alien-callback emit-node
|
||||
dup params>> xt>> dup
|
||||
|
@ -193,7 +193,7 @@ M: #alien-callback emit-node
|
|||
begin-word
|
||||
|
||||
{
|
||||
[ params>> callee-parameters ##callback-inputs ]
|
||||
[ params>> callee-parameters <##callback-inputs> ]
|
||||
[ params>> box-parameters ]
|
||||
[ child>> emit-callback-body ]
|
||||
[ params>> emit-callback-return ]
|
||||
|
|
|
@ -52,7 +52,7 @@ M: object flatten-struct-type-return
|
|||
|
||||
:: implode-struct ( src vregs reps -- )
|
||||
vregs reps dup component-offsets
|
||||
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
|
||||
[| vreg rep offset | vreg src offset rep f <##store-memory-imm> ] 3each ;
|
||||
|
||||
GENERIC: unbox ( src c-type -- vregs reps )
|
||||
|
||||
|
@ -75,7 +75,7 @@ M: c-type unbox
|
|||
[ drop f f 3array 1array ] 2bi ;
|
||||
|
||||
M: long-long-type unbox
|
||||
[ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array
|
||||
[ next-vreg next-vreg 2dup ] 2dip unboxer>> <##unbox-long-long> 2array
|
||||
int-rep long-long-on-stack? long-long-odd-register? 3array
|
||||
int-rep long-long-on-stack? f 3array 2array ;
|
||||
|
||||
|
|
|
@ -27,9 +27,9 @@ IN: compiler.cfg.builder.blocks
|
|||
(begin-basic-block) ;
|
||||
|
||||
: emit-trivial-block ( quot -- )
|
||||
##branch begin-basic-block
|
||||
<##branch> begin-basic-block
|
||||
call
|
||||
##branch begin-basic-block ; inline
|
||||
<##branch> begin-basic-block ; inline
|
||||
|
||||
: make-kill-block ( -- )
|
||||
basic-block get t >>kill-block? drop ;
|
||||
|
@ -39,7 +39,7 @@ IN: compiler.cfg.builder.blocks
|
|||
|
||||
: emit-primitive ( node -- )
|
||||
[
|
||||
[ word>> ##call ]
|
||||
[ word>> <##call> ]
|
||||
[ call-height adjust-d ] bi
|
||||
make-kill-block
|
||||
] emit-trivial-block ;
|
||||
|
@ -49,7 +49,7 @@ IN: compiler.cfg.builder.blocks
|
|||
: end-branch ( -- pair/f )
|
||||
! pair is { final-bb final-height }
|
||||
basic-block get dup [
|
||||
##branch
|
||||
<##branch>
|
||||
end-local-analysis
|
||||
current-height get clone 2array
|
||||
] when ;
|
||||
|
|
|
@ -57,8 +57,8 @@ GENERIC: emit-node ( node -- )
|
|||
|
||||
: begin-word ( -- )
|
||||
make-kill-block
|
||||
##prologue
|
||||
##branch
|
||||
<##prologue>
|
||||
<##branch>
|
||||
begin-basic-block ;
|
||||
|
||||
: (build-cfg) ( nodes word label -- )
|
||||
|
@ -75,8 +75,8 @@ GENERIC: emit-node ( node -- )
|
|||
] keep ;
|
||||
|
||||
: emit-loop-call ( basic-block -- )
|
||||
##safepoint
|
||||
##branch
|
||||
<##safepoint>
|
||||
<##branch>
|
||||
basic-block get successors>> push
|
||||
end-basic-block ;
|
||||
|
||||
|
@ -85,7 +85,7 @@ GENERIC: emit-node ( node -- )
|
|||
[ drop loops get at emit-loop-call ]
|
||||
[
|
||||
[
|
||||
[ ##call ] [ adjust-d ] bi*
|
||||
[ <##call> ] [ adjust-d ] bi*
|
||||
make-kill-block
|
||||
] emit-trivial-block
|
||||
] if ;
|
||||
|
@ -102,7 +102,7 @@ GENERIC: emit-node ( node -- )
|
|||
basic-block get swap loops get set-at ;
|
||||
|
||||
: emit-loop ( node -- )
|
||||
##branch
|
||||
<##branch>
|
||||
begin-basic-block
|
||||
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
|
||||
|
||||
|
@ -142,7 +142,7 @@ M: #recursive emit-node
|
|||
: emit-actual-if ( #if -- )
|
||||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync
|
||||
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch emit-if ;
|
||||
ds-pop any-rep ^^copy f cc/= <##compare-imm-branch> emit-if ;
|
||||
|
||||
M: #if emit-node
|
||||
{
|
||||
|
@ -156,7 +156,7 @@ M: #dispatch emit-node
|
|||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
|
||||
! though.
|
||||
ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
|
||||
ds-pop ^^offset>slot next-vreg <##dispatch> emit-if ;
|
||||
|
||||
! #call
|
||||
M: #call emit-node
|
||||
|
@ -200,12 +200,12 @@ M: #shuffle emit-node
|
|||
|
||||
! #return
|
||||
: end-word ( -- )
|
||||
##branch
|
||||
<##branch>
|
||||
begin-basic-block
|
||||
make-kill-block
|
||||
##safepoint
|
||||
##epilogue
|
||||
##return ;
|
||||
<##safepoint>
|
||||
<##epilogue>
|
||||
<##return> ;
|
||||
|
||||
M: #return emit-node drop end-word ;
|
||||
|
||||
|
@ -213,7 +213,7 @@ M: #return-recursive emit-node
|
|||
label>> id>> loops get key? [ end-word ] unless ;
|
||||
|
||||
! #terminate
|
||||
M: #terminate emit-node drop ##no-tco end-basic-block ;
|
||||
M: #terminate emit-node drop <##no-tco> end-basic-block ;
|
||||
|
||||
! No-op nodes
|
||||
M: #introduce emit-node drop ;
|
||||
|
|
|
@ -85,7 +85,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
|||
|
||||
: <gc-call> ( -- bb )
|
||||
<basic-block>
|
||||
[ <gc-map> ##call-gc ##branch ] V{ } make
|
||||
[ <gc-map> <##call-gc> <##branch> ] V{ } make
|
||||
>>instructions t >>unlikely? ;
|
||||
|
||||
:: connect-gc-checks ( bbs -- )
|
||||
|
|
|
@ -23,7 +23,7 @@ IN: compiler.cfg.hats
|
|||
[ drop [ ] ]
|
||||
} case swap [ dip ] curry compose
|
||||
] reduce
|
||||
] keep suffix ;
|
||||
] keep insn-ctor-name "compiler.cfg.instructions" lookup-word suffix ;
|
||||
|
||||
: hat-effect ( insn -- effect )
|
||||
"insn-slots" word-prop
|
||||
|
|
|
@ -71,8 +71,11 @@ TUPLE: insn-slot-spec type name rep ;
|
|||
: define-insn-tuple ( class superclass specs -- )
|
||||
[ name>> ] map "insn#" suffix define-tuple-class ;
|
||||
|
||||
: insn-ctor-name ( word -- name )
|
||||
name>> "<" ">" surround ;
|
||||
|
||||
: define-insn-ctor ( class specs -- )
|
||||
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
|
||||
[ [ insn-ctor-name create-in ] [ '[ _ ] [ f ] [ boa , ] surround ] bi ] dip
|
||||
[ name>> ] map { } <effect> define-declared ;
|
||||
|
||||
: define-insn ( class superclass specs -- )
|
||||
|
|
|
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
|
||||
:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- )
|
||||
node
|
||||
[ prepare-quot call rep c-type ##store-memory-imm ]
|
||||
[ prepare-quot call rep c-type <##store-memory-imm> ]
|
||||
[ test-quot call inline-store-memory? ]
|
||||
inline-accessor ; inline
|
||||
|
||||
|
|
|
@ -8,13 +8,13 @@ compiler.cfg.utilities compiler.cfg.builder.blocks
|
|||
compiler.constants cpu.architecture alien.c-types ;
|
||||
IN: compiler.cfg.intrinsics.allot
|
||||
|
||||
: ##set-slots ( regs obj class -- )
|
||||
'[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
|
||||
: <##set-slots> ( regs obj class -- )
|
||||
'[ _ swap 1 + _ type-number <##set-slot-imm> ] each-index ;
|
||||
|
||||
: emit-simple-allot ( node -- )
|
||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||
[ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
|
||||
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
|
||||
[ <##set-slots> ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
|
||||
|
||||
: tuple-slot-regs ( layout -- vregs )
|
||||
[ second ds-load ] [ ^^load-literal ] bi prefix ;
|
||||
|
@ -28,14 +28,14 @@ IN: compiler.cfg.intrinsics.allot
|
|||
nip
|
||||
ds-drop
|
||||
[ tuple-slot-regs ] [ second ^^allot-tuple ] bi
|
||||
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
||||
[ tuple <##set-slots> ] [ ds-push drop ] 2bi
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: store-length ( len reg class -- )
|
||||
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
|
||||
[ [ ^^load-literal ] dip 1 ] dip type-number <##set-slot-imm> ;
|
||||
|
||||
:: store-initial-element ( len reg elt class -- )
|
||||
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
|
||||
len [ [ elt reg ] dip 2 + class type-number <##set-slot-imm> ] each-integer ;
|
||||
|
||||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
@ -76,7 +76,7 @@ IN: compiler.cfg.intrinsics.allot
|
|||
0 ^^load-literal :> elt
|
||||
reg ^^tagged>integer :> reg
|
||||
len cell align cell /i iota [
|
||||
[ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm
|
||||
[ elt reg ] dip cells byte-array-offset + int-rep f <##store-memory-imm>
|
||||
] each ;
|
||||
|
||||
:: emit-<byte-array> ( node -- )
|
||||
|
|
|
@ -32,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
] binary-op ;
|
||||
|
||||
: emit-fixnum-shift-general ( -- )
|
||||
ds-peek 0 cc> ##compare-integer-imm-branch
|
||||
ds-peek 0 cc> <##compare-integer-imm-branch>
|
||||
[ emit-fixnum-left-shift ] with-branch
|
||||
[ emit-fixnum-right-shift ] with-branch
|
||||
2array emit-conditional ;
|
||||
|
@ -52,7 +52,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
|
||||
: emit-overflow-case ( word -- final-bb )
|
||||
[
|
||||
##call
|
||||
<##call>
|
||||
-1 adjust-d
|
||||
make-kill-block
|
||||
] with-branch ;
|
||||
|
@ -77,4 +77,4 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
|
||||
|
||||
: emit-fixnum* ( -- )
|
||||
[ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
|
||||
[ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
|
||||
|
|
|
@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.misc
|
|||
: emit-set-special-object ( node -- )
|
||||
dup node-input-infos second literal>> [
|
||||
ds-drop
|
||||
[ ds-pop ] dip special-object-offset ##set-vm-field
|
||||
[ ds-pop ] dip special-object-offset <##set-vm-field>
|
||||
] [ emit-primitive ] ?if ;
|
||||
|
||||
: context-object-offset ( n -- n )
|
||||
|
@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.misc
|
|||
if ;
|
||||
|
||||
: emit-cleanup-allot ( -- )
|
||||
[ ##no-tco ] emit-trivial-block ;
|
||||
[ <##no-tco> ] emit-trivial-block ;
|
||||
|
|
|
@ -632,7 +632,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
|
|||
dup [
|
||||
'[
|
||||
ds-drop prepare-store-memory
|
||||
_ f ##store-memory-imm
|
||||
_ f <##store-memory-imm>
|
||||
]
|
||||
[ byte-array inline-store-memory? ]
|
||||
inline-accessor
|
||||
|
|
|
@ -52,10 +52,10 @@ IN: compiler.cfg.intrinsics.slots
|
|||
infos second value-tag :> tag
|
||||
|
||||
slot tag slot-indexing :> ( slot scale tag )
|
||||
src obj slot scale tag ##set-slot
|
||||
src obj slot scale tag <##set-slot>
|
||||
|
||||
infos emit-write-barrier?
|
||||
[ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
|
||||
[ obj slot scale tag next-vreg next-vreg <##write-barrier> ] when ;
|
||||
|
||||
:: (emit-set-slot-imm) ( infos -- )
|
||||
ds-drop
|
||||
|
@ -65,10 +65,10 @@ IN: compiler.cfg.intrinsics.slots
|
|||
infos third literal>> :> slot
|
||||
infos second value-tag :> tag
|
||||
|
||||
src obj slot tag ##set-slot-imm
|
||||
src obj slot tag <##set-slot-imm>
|
||||
|
||||
infos emit-write-barrier?
|
||||
[ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
|
||||
[ obj slot tag next-vreg next-vreg <##write-barrier-imm> ] when ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
dup node-input-infos
|
||||
|
|
|
@ -12,4 +12,4 @@ IN: compiler.cfg.intrinsics.strings
|
|||
2inputs (string-nth) ^^load-memory-imm ds-push ;
|
||||
|
||||
: emit-set-string-nth-fast ( -- )
|
||||
3inputs (string-nth) ##store-memory-imm ;
|
||||
3inputs (string-nth) <##store-memory-imm> ;
|
||||
|
|
|
@ -97,7 +97,7 @@ SYMBOL: machine-live-outs
|
|||
init-unhandled ;
|
||||
|
||||
: insert-spill ( live-interval -- )
|
||||
[ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ;
|
||||
[ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri <##spill> ;
|
||||
|
||||
: handle-spill ( live-interval -- )
|
||||
dup spill-to>> [ insert-spill ] [ drop ] if ;
|
||||
|
@ -117,7 +117,7 @@ SYMBOL: machine-live-outs
|
|||
pending-interval-heap get (expire-old-intervals) ;
|
||||
|
||||
: insert-reload ( live-interval -- )
|
||||
[ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ;
|
||||
[ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri <##reload> ;
|
||||
|
||||
: handle-reload ( live-interval -- )
|
||||
dup reload-from>> [ insert-reload ] [ drop ] if ;
|
||||
|
|
|
@ -60,19 +60,19 @@ SYMBOL: spill-temps
|
|||
] if ;
|
||||
|
||||
: memory->register ( from to -- )
|
||||
swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ;
|
||||
swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* <##reload> ;
|
||||
|
||||
: register->memory ( from to -- )
|
||||
[ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ;
|
||||
[ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* <##spill> ;
|
||||
|
||||
: temp->register ( from to -- )
|
||||
nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ;
|
||||
nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri <##reload> ;
|
||||
|
||||
: register->temp ( from to -- )
|
||||
drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ;
|
||||
drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi <##spill> ;
|
||||
|
||||
: register->register ( from to -- )
|
||||
swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
|
||||
swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* <##copy> ;
|
||||
|
||||
SYMBOL: temp
|
||||
|
||||
|
@ -87,7 +87,7 @@ SYMBOL: temp
|
|||
|
||||
: mapping-instructions ( alist -- insns )
|
||||
[ swap ] H{ } assoc-map-as
|
||||
[ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
|
||||
[ temp [ swap >insn ] parallel-mapping <##branch> ] { } make ;
|
||||
|
||||
: perform-mappings ( bb to mappings -- )
|
||||
dup empty? [ 3drop ] [
|
||||
|
|
|
@ -58,4 +58,4 @@ PRIVATE>
|
|||
] with-scope ; inline
|
||||
|
||||
: parallel-copy ( mapping -- )
|
||||
next-vreg [ any-rep ##copy ] parallel-mapping ;
|
||||
next-vreg [ any-rep <##copy> ] parallel-mapping ;
|
||||
|
|
|
@ -11,73 +11,73 @@ GENERIC: rep>tagged ( dst src rep -- )
|
|||
GENERIC: tagged>rep ( dst src rep -- )
|
||||
|
||||
M: int-rep rep>tagged ( dst src rep -- )
|
||||
drop tag-bits get ##shl-imm ;
|
||||
drop tag-bits get <##shl-imm> ;
|
||||
|
||||
M: int-rep tagged>rep ( dst src rep -- )
|
||||
drop tag-bits get ##sar-imm ;
|
||||
drop tag-bits get <##sar-imm> ;
|
||||
|
||||
M:: float-rep rep>tagged ( dst src rep -- )
|
||||
double-rep next-vreg-rep :> temp
|
||||
temp src ##single>double-float
|
||||
temp src <##single>double-float>
|
||||
dst temp double-rep rep>tagged ;
|
||||
|
||||
M:: float-rep tagged>rep ( dst src rep -- )
|
||||
double-rep next-vreg-rep :> temp
|
||||
temp src double-rep tagged>rep
|
||||
dst temp ##double>single-float ;
|
||||
dst temp <##double>single-float> ;
|
||||
|
||||
M:: double-rep rep>tagged ( dst src rep -- )
|
||||
dst 16 float int-rep next-vreg-rep ##allot
|
||||
src dst float-offset double-rep f ##store-memory-imm ;
|
||||
dst 16 float int-rep next-vreg-rep <##allot>
|
||||
src dst float-offset double-rep f <##store-memory-imm> ;
|
||||
|
||||
M: double-rep tagged>rep
|
||||
drop float-offset double-rep f ##load-memory-imm ;
|
||||
drop float-offset double-rep f <##load-memory-imm> ;
|
||||
|
||||
M:: vector-rep rep>tagged ( dst src rep -- )
|
||||
tagged-rep next-vreg-rep :> temp
|
||||
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
|
||||
temp 16 tag-fixnum ##load-tagged
|
||||
temp dst 1 byte-array type-number ##set-slot-imm
|
||||
src dst byte-array-offset rep f ##store-memory-imm ;
|
||||
dst 16 2 cells + byte-array int-rep next-vreg-rep <##allot>
|
||||
temp 16 tag-fixnum <##load-tagged>
|
||||
temp dst 1 byte-array type-number <##set-slot-imm>
|
||||
src dst byte-array-offset rep f <##store-memory-imm> ;
|
||||
|
||||
M: vector-rep tagged>rep
|
||||
[ byte-array-offset ] dip f ##load-memory-imm ;
|
||||
[ byte-array-offset ] dip f <##load-memory-imm> ;
|
||||
|
||||
M:: scalar-rep rep>tagged ( dst src rep -- )
|
||||
tagged-rep next-vreg-rep :> temp
|
||||
temp src rep ##scalar>integer
|
||||
temp src rep <##scalar>integer>
|
||||
dst temp int-rep rep>tagged ;
|
||||
|
||||
M:: scalar-rep tagged>rep ( dst src rep -- )
|
||||
tagged-rep next-vreg-rep :> temp
|
||||
temp src int-rep tagged>rep
|
||||
dst temp rep ##integer>scalar ;
|
||||
dst temp rep <##integer>scalar> ;
|
||||
|
||||
GENERIC: rep>int ( dst src rep -- )
|
||||
GENERIC: int>rep ( dst src rep -- )
|
||||
|
||||
M: scalar-rep rep>int ( dst src rep -- )
|
||||
##scalar>integer ;
|
||||
<##scalar>integer> ;
|
||||
|
||||
M: scalar-rep int>rep ( dst src rep -- )
|
||||
##integer>scalar ;
|
||||
<##integer>scalar> ;
|
||||
|
||||
: emit-conversion ( dst src dst-rep src-rep -- )
|
||||
{
|
||||
{ [ 2dup eq? ] [ drop ##copy ] }
|
||||
{ [ 2dup eq? ] [ drop <##copy> ] }
|
||||
{ [ dup tagged-rep? ] [ drop tagged>rep ] }
|
||||
{ [ over tagged-rep? ] [ nip rep>tagged ] }
|
||||
{ [ dup int-rep? ] [ drop int>rep ] }
|
||||
{ [ over int-rep? ] [ nip rep>int ] }
|
||||
[
|
||||
2dup 2array {
|
||||
{ { double-rep float-rep } [ 2drop ##single>double-float ] }
|
||||
{ { float-rep double-rep } [ 2drop ##double>single-float ] }
|
||||
{ { double-rep float-rep } [ 2drop <##single>double-float> ] }
|
||||
{ { float-rep double-rep } [ 2drop <##double>single-float> ] }
|
||||
! Punning SIMD vector types? Naughty naughty! But
|
||||
! it is allowed... otherwise bail out.
|
||||
[
|
||||
drop 2dup [ reg-class-of ] bi@ eq?
|
||||
[ drop ##copy ] [ bad-conversion ] if
|
||||
[ drop <##copy> ] [ bad-conversion ] if
|
||||
]
|
||||
} case
|
||||
]
|
||||
|
|
|
@ -37,7 +37,7 @@ M: ##load-integer optimize-insn
|
|||
{
|
||||
{
|
||||
[ dup dst>> rep-of tagged-rep? ]
|
||||
[ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ]
|
||||
[ [ dst>> ] [ val>> tag-fixnum ] bi <##load-tagged> here ]
|
||||
}
|
||||
[ call-next-method ]
|
||||
} cond ;
|
||||
|
@ -84,23 +84,23 @@ M: ##load-reference optimize-insn
|
|||
{
|
||||
{
|
||||
[ dup convert-to-load-float? ]
|
||||
[ [ dst>> ] [ obj>> ] bi ##load-float here ]
|
||||
[ [ dst>> ] [ obj>> ] bi <##load-float> here ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-load-double? ]
|
||||
[ [ dst>> ] [ obj>> ] bi ##load-double here ]
|
||||
[ [ dst>> ] [ obj>> ] bi <##load-double> here ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-zero-vector? ]
|
||||
[ dst>> dup rep-of ##zero-vector here ]
|
||||
[ dst>> dup rep-of <##zero-vector> here ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-fill-vector? ]
|
||||
[ dst>> dup rep-of ##fill-vector here ]
|
||||
[ dst>> dup rep-of <##fill-vector> here ]
|
||||
}
|
||||
{
|
||||
[ dup convert-to-load-vector? ]
|
||||
[ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ]
|
||||
[ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri <##load-vector> here ]
|
||||
}
|
||||
[ call-next-method ]
|
||||
} cond ;
|
||||
|
@ -113,9 +113,9 @@ M: ##load-reference optimize-insn
|
|||
! ##sar-imm by tag-bits - X.
|
||||
: combine-shl-imm-input ( insn -- )
|
||||
[ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
|
||||
{ [ 2dup < ] [ swap - ##sar-imm here ] }
|
||||
{ [ 2dup > ] [ - ##shl-imm here ] }
|
||||
[ 2drop int-rep ##copy here ]
|
||||
{ [ 2dup < ] [ swap - <##sar-imm> here ] }
|
||||
{ [ 2dup > ] [ - <##shl-imm> here ] }
|
||||
[ 2drop int-rep <##copy> here ]
|
||||
} cond ;
|
||||
|
||||
: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
|
||||
|
@ -260,7 +260,7 @@ M: ##test-branch optimize-insn
|
|||
[ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
|
||||
|
||||
: combine-neg-tag ( insn -- )
|
||||
[ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ;
|
||||
[ dst>> ] [ src>> ] bi tag-bits get 2^ neg <##mul-imm> here ;
|
||||
|
||||
M: ##neg optimize-insn
|
||||
{
|
||||
|
@ -276,8 +276,8 @@ M: ##neg optimize-insn
|
|||
! tag(not(untag(x))) = not(x) xor tag-mask
|
||||
:: emit-tagged-not ( insn -- )
|
||||
tagged-rep next-vreg-rep :> temp
|
||||
temp insn src>> ##not
|
||||
insn dst>> temp tag-mask get ##xor-imm here ;
|
||||
temp insn src>> <##not>
|
||||
insn dst>> temp tag-mask get <##xor-imm> here ;
|
||||
|
||||
M: ##not optimize-insn
|
||||
{
|
||||
|
|
|
@ -23,7 +23,7 @@ IN: compiler.cfg.ssa.cssa
|
|||
:: insert-copy ( bb src rep -- bb dst )
|
||||
bb src insert-copy? [
|
||||
rep next-vreg-rep :> dst
|
||||
bb [ dst src rep ##copy ] add-instructions
|
||||
bb [ dst src rep <##copy> ] add-instructions
|
||||
bb dst
|
||||
] [ bb src ] if ;
|
||||
|
||||
|
@ -31,4 +31,4 @@ IN: compiler.cfg.ssa.cssa
|
|||
dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
|
||||
|
||||
: construct-cssa ( cfg -- )
|
||||
[ [ convert-phi ] each-phi ] each-basic-block ;
|
||||
[ [ convert-phi ] each-phi ] each-basic-block ;
|
||||
|
|
|
@ -34,17 +34,17 @@ ERROR: bad-peek dst loc ;
|
|||
|
||||
: insert-peeks ( from to -- )
|
||||
[ inserting-peeks ] keep
|
||||
[ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ;
|
||||
[ dup n>> 0 < [ bad-peek ] [ <##peek> ] if ] each-insertion ;
|
||||
|
||||
: insert-replaces ( from to -- )
|
||||
[ inserting-replaces ] keep
|
||||
[ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
|
||||
[ dup n>> 0 < [ 2drop ] [ <##replace> ] if ] each-insertion ;
|
||||
|
||||
: visit-edge ( from to -- )
|
||||
! If both blocks are subroutine calls, don't bother
|
||||
! computing anything.
|
||||
2dup [ kill-block?>> ] both? [ 2drop ] [
|
||||
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
|
||||
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi <##branch> ] V{ } make
|
||||
[ 2drop ] [ insert-basic-block ] if-empty
|
||||
] if ;
|
||||
|
||||
|
|
|
@ -45,8 +45,8 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
|
||||
: emit-height-changes ( -- )
|
||||
current-height get
|
||||
[ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
|
||||
[ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
|
||||
[ emit-d>> dup 0 = [ drop ] [ <##inc-d> ] if ]
|
||||
[ emit-r>> dup 0 = [ drop ] [ <##inc-r> ] if ] bi ;
|
||||
|
||||
: emit-changes ( -- )
|
||||
! Insert height and stack changes prior to the last instruction
|
||||
|
|
|
@ -31,7 +31,7 @@ M: ##box-displaced-alien rewrite
|
|||
[ dst>> ]
|
||||
[ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi*
|
||||
[ ^^unbox-c-ptr ] dip
|
||||
##add
|
||||
<##add>
|
||||
] { } make ;
|
||||
|
||||
: rewrite-unbox-any-c-ptr ( insn -- insn/f )
|
||||
|
|
|
@ -136,8 +136,8 @@ M: ##mul-imm rewrite
|
|||
{ [ dup mul-to-neg? ] [ mul-to-neg ] }
|
||||
{ [ dup mul-to-shl? ] [ mul-to-shl ] }
|
||||
{ [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
|
||||
{ [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
|
||||
{ [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
|
||||
{ [ dup distribute-over-add? ] [ \ <##add-imm> \ <##mul-imm> distribute ] }
|
||||
{ [ dup distribute-over-sub? ] [ \ <##sub-imm> \ <##mul-imm> distribute ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
|
@ -173,8 +173,8 @@ M: ##shl-imm rewrite
|
|||
{ [ dup src2>> 0 = ] [ identity ] }
|
||||
{ [ dup binary-constant-fold? ] [ binary-constant-fold ] }
|
||||
{ [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
|
||||
{ [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
|
||||
{ [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
|
||||
{ [ dup distribute-over-add? ] [ \ <##add-imm> \ <##shl-imm> distribute ] }
|
||||
{ [ dup distribute-over-sub? ] [ \ <##sub-imm> \ <##shl-imm> distribute ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue