Working on comparison operations, clearing out remaining dead wood
parent
28e82c892c
commit
94a2bfa2ea
|
@ -65,14 +65,12 @@ GENERIC: emit-node ( node -- next )
|
||||||
basic-block get [ drop f ] unless ; inline
|
basic-block get [ drop f ] unless ; inline
|
||||||
|
|
||||||
: emit-nodes ( nodes -- )
|
: emit-nodes ( nodes -- )
|
||||||
[ current-node emit-node check-basic-block ] iterate-nodes
|
[ current-node emit-node check-basic-block ] iterate-nodes ;
|
||||||
finalize-phantoms ;
|
|
||||||
|
|
||||||
: begin-word ( -- )
|
: begin-word ( -- )
|
||||||
#! We store the basic block after the prologue as a loop
|
#! We store the basic block after the prologue as a loop
|
||||||
#! labelled by the current word, so that self-recursive
|
#! labelled by the current word, so that self-recursive
|
||||||
#! calls can skip an epilogue/prologue.
|
#! calls can skip an epilogue/prologue.
|
||||||
init-phantoms
|
|
||||||
##prologue
|
##prologue
|
||||||
##branch
|
##branch
|
||||||
begin-basic-block
|
begin-basic-block
|
||||||
|
@ -98,7 +96,6 @@ GENERIC: emit-node ( node -- next )
|
||||||
stop-iterating ;
|
stop-iterating ;
|
||||||
|
|
||||||
: emit-call ( word -- next )
|
: emit-call ( word -- next )
|
||||||
finalize-phantoms
|
|
||||||
{
|
{
|
||||||
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
|
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
|
||||||
{ [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
|
{ [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
|
||||||
|
@ -115,7 +112,6 @@ GENERIC: emit-node ( node -- next )
|
||||||
basic-block get swap loops get set-at ;
|
basic-block get swap loops get set-at ;
|
||||||
|
|
||||||
: compile-loop ( node -- next )
|
: compile-loop ( node -- next )
|
||||||
finalize-phantoms
|
|
||||||
begin-basic-block
|
begin-basic-block
|
||||||
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
|
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
|
||||||
iterate-next ;
|
iterate-next ;
|
||||||
|
@ -126,7 +122,7 @@ M: #recursive emit-node
|
||||||
! #if
|
! #if
|
||||||
: emit-branch ( obj -- final-bb )
|
: emit-branch ( obj -- final-bb )
|
||||||
[
|
[
|
||||||
begin-basic-block copy-phantoms
|
begin-basic-block
|
||||||
emit-nodes
|
emit-nodes
|
||||||
basic-block get dup [ ##branch ] when
|
basic-block get dup [ ##branch ] when
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
@ -135,21 +131,19 @@ M: #recursive emit-node
|
||||||
children>> [ emit-branch ] map
|
children>> [ emit-branch ] map
|
||||||
end-basic-block
|
end-basic-block
|
||||||
begin-basic-block
|
begin-basic-block
|
||||||
basic-block get '[ [ _ swap successors>> push ] when* ] each
|
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
|
||||||
init-phantoms ;
|
|
||||||
|
|
||||||
: ##branch-t ( vreg -- )
|
: ##branch-t ( vreg -- )
|
||||||
\ f tag-number cc/= ##compare-imm-branch ;
|
\ f tag-number cc/= ##compare-imm-branch ;
|
||||||
|
|
||||||
M: #if emit-node
|
M: #if emit-node
|
||||||
phantom-pop ##branch-t emit-if iterate-next ;
|
ds-pop ##branch-t emit-if iterate-next ;
|
||||||
|
|
||||||
! #dispatch
|
! #dispatch
|
||||||
: dispatch-branch ( nodes word -- label )
|
: dispatch-branch ( nodes word -- label )
|
||||||
gensym [
|
gensym [
|
||||||
[
|
[
|
||||||
V{ } clone node-stack set
|
V{ } clone node-stack set
|
||||||
init-phantoms
|
|
||||||
##prologue
|
##prologue
|
||||||
emit-nodes
|
emit-nodes
|
||||||
basic-block get [
|
basic-block get [
|
||||||
|
@ -167,11 +161,9 @@ M: #if emit-node
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: emit-dispatch ( node -- )
|
: emit-dispatch ( node -- )
|
||||||
phantom-pop int-regs next-vreg
|
##epilogue
|
||||||
[ finalize-phantoms ##epilogue ] 2dip
|
ds-pop ^^offset>slot i ##dispatch
|
||||||
[ ^^offset>slot ] dip
|
dispatch-branches ;
|
||||||
##dispatch
|
|
||||||
dispatch-branches init-phantoms ;
|
|
||||||
|
|
||||||
: <dispatch-block> ( -- word )
|
: <dispatch-block> ( -- word )
|
||||||
gensym dup t "inlined-block" set-word-prop ;
|
gensym dup t "inlined-block" set-word-prop ;
|
||||||
|
@ -198,34 +190,36 @@ M: #call-recursive emit-node label>> id>> emit-call ;
|
||||||
|
|
||||||
! #push
|
! #push
|
||||||
M: #push emit-node
|
M: #push emit-node
|
||||||
literal>> ^^load-literal phantom-push iterate-next ;
|
literal>> ^^load-literal ds-push iterate-next ;
|
||||||
|
|
||||||
! #shuffle
|
! #shuffle
|
||||||
|
: emit-shuffle ( effect -- )
|
||||||
|
[ out>> ] [ in>> dup length ds-load zip ] bi
|
||||||
|
'[ _ at ] map ds-store ;
|
||||||
|
|
||||||
M: #shuffle emit-node
|
M: #shuffle emit-node
|
||||||
shuffle-effect phantom-shuffle iterate-next ;
|
shuffle-effect emit-shuffle iterate-next ;
|
||||||
|
|
||||||
M: #>r emit-node
|
M: #>r emit-node
|
||||||
[ in-d>> length ] [ out-r>> empty? ] bi
|
[ in-d>> length ] [ out-r>> empty? ] bi
|
||||||
[ phantom-drop ] [ phantom->r ] if
|
[ neg ##inc-d ] [ ds-load rs-store ] if
|
||||||
iterate-next ;
|
iterate-next ;
|
||||||
|
|
||||||
M: #r> emit-node
|
M: #r> emit-node
|
||||||
[ in-r>> length ] [ out-d>> empty? ] bi
|
[ in-r>> length ] [ out-d>> empty? ] bi
|
||||||
[ phantom-rdrop ] [ phantom-r> ] if
|
[ neg ##inc-r ] [ rs-load ds-store ] if
|
||||||
iterate-next ;
|
iterate-next ;
|
||||||
|
|
||||||
! #return
|
! #return
|
||||||
M: #return emit-node
|
M: #return emit-node
|
||||||
drop finalize-phantoms ##epilogue ##return stop-iterating ;
|
drop ##epilogue ##return stop-iterating ;
|
||||||
|
|
||||||
M: #return-recursive emit-node
|
M: #return-recursive emit-node
|
||||||
finalize-phantoms
|
|
||||||
label>> id>> loops get key?
|
label>> id>> loops get key?
|
||||||
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
|
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
|
||||||
|
|
||||||
! #terminate
|
! #terminate
|
||||||
M: #terminate emit-node
|
M: #terminate emit-node drop stop-iterating ;
|
||||||
drop finalize-phantoms stop-iterating ;
|
|
||||||
|
|
||||||
! FFI
|
! FFI
|
||||||
: return-size ( ctype -- n )
|
: return-size ( ctype -- n )
|
||||||
|
@ -246,7 +240,6 @@ M: #terminate emit-node
|
||||||
<alien-stack-frame> ##stack-frame ;
|
<alien-stack-frame> ##stack-frame ;
|
||||||
|
|
||||||
: emit-alien-node ( node quot -- next )
|
: emit-alien-node ( node quot -- next )
|
||||||
finalize-phantoms
|
|
||||||
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
|
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
|
||||||
iterate-next ; inline
|
iterate-next ; inline
|
||||||
|
|
||||||
|
@ -259,7 +252,6 @@ M: #alien-indirect emit-node
|
||||||
M: #alien-callback emit-node
|
M: #alien-callback emit-node
|
||||||
dup params>> xt>> dup
|
dup params>> xt>> dup
|
||||||
[
|
[
|
||||||
init-phantoms
|
|
||||||
##prologue
|
##prologue
|
||||||
dup [ ##alien-callback ] emit-alien-node drop
|
dup [ ##alien-callback ] emit-alien-node drop
|
||||||
##epilogue
|
##epilogue
|
||||||
|
|
|
@ -13,6 +13,8 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
|
||||||
M: ##unary/temp defs-vregs dst/tmp-vregs ;
|
M: ##unary/temp defs-vregs dst/tmp-vregs ;
|
||||||
M: ##allot defs-vregs dst/tmp-vregs ;
|
M: ##allot defs-vregs dst/tmp-vregs ;
|
||||||
M: ##dispatch defs-vregs temp>> 1array ;
|
M: ##dispatch defs-vregs temp>> 1array ;
|
||||||
|
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
||||||
|
M: ##set-slot defs-vregs temp>> 1array ;
|
||||||
M: insn defs-vregs drop f ;
|
M: insn defs-vregs drop f ;
|
||||||
|
|
||||||
M: ##unary uses-vregs src>> 1array ;
|
M: ##unary uses-vregs src>> 1array ;
|
||||||
|
|
|
@ -5,13 +5,6 @@ sequences classes.tuple cpu.architecture compiler.cfg.registers
|
||||||
compiler.cfg.instructions ;
|
compiler.cfg.instructions ;
|
||||||
IN: compiler.cfg.hats
|
IN: compiler.cfg.hats
|
||||||
|
|
||||||
! 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? ;
|
|
||||||
|
|
||||||
: i int-regs next-vreg ; inline
|
: i int-regs next-vreg ; inline
|
||||||
: ^^i i dup ; inline
|
: ^^i i dup ; inline
|
||||||
: ^^i1 [ ^^i ] dip ; inline
|
: ^^i1 [ ^^i ] dip ; inline
|
||||||
|
@ -53,11 +46,10 @@ SYMBOL: fresh-objects
|
||||||
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
|
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
|
||||||
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
|
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
|
||||||
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
|
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
|
||||||
: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline
|
: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
|
||||||
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
||||||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||||
: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline
|
|
||||||
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
|
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
|
||||||
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
|
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
|
||||||
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
|
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
|
||||||
|
@ -72,9 +64,9 @@ SYMBOL: fresh-objects
|
||||||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||||
: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
|
: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
|
||||||
: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
|
: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
|
||||||
: ^^compare ( src1 src2 -- dst ) ^^i2 ##compare ; inline
|
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
|
||||||
: ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
|
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
|
||||||
: ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline
|
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
|
||||||
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
|
||||||
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
|
||||||
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
|
||||||
|
|
|
@ -8,15 +8,15 @@ compiler.cfg.intrinsics.utilities ;
|
||||||
IN: compiler.cfg.intrinsics.alien
|
IN: compiler.cfg.intrinsics.alien
|
||||||
|
|
||||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||||
1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
||||||
|
|
||||||
: (prepare-alien-accessor) ( class -- offset-vreg )
|
: (prepare-alien-accessor) ( class -- offset-vreg )
|
||||||
[ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
[ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
|
||||||
|
|
||||||
: prepare-alien-accessor ( infos -- offset-vreg )
|
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||||
<reversed> [ second class>> ] [ first ] bi
|
<reversed> [ second class>> ] [ first ] bi
|
||||||
dup value-info-small-tagged? [
|
dup value-info-small-tagged? [
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
literal>> (prepare-alien-accessor-imm)
|
literal>> (prepare-alien-accessor-imm)
|
||||||
] [ drop (prepare-alien-accessor) ] if ;
|
] [ drop (prepare-alien-accessor) ] if ;
|
||||||
|
|
||||||
|
@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.alien
|
||||||
bi and ;
|
bi and ;
|
||||||
|
|
||||||
: inline-alien-getter ( node quot -- )
|
: inline-alien-getter ( node quot -- )
|
||||||
'[ @ phantom-push ]
|
'[ @ ds-push ]
|
||||||
[ inline-alien-getter? ] inline-alien ; inline
|
[ inline-alien-getter? ] inline-alien ; inline
|
||||||
|
|
||||||
: inline-alien-setter? ( infos class -- ? )
|
: inline-alien-setter? ( infos class -- ? )
|
||||||
|
@ -44,18 +44,18 @@ IN: compiler.cfg.intrinsics.alien
|
||||||
tri and and ;
|
tri and and ;
|
||||||
|
|
||||||
: inline-alien-integer-setter ( node quot -- )
|
: inline-alien-integer-setter ( node quot -- )
|
||||||
'[ phantom-pop ^^untag-fixnum @ ]
|
'[ ds-pop ^^untag-fixnum @ ]
|
||||||
[ fixnum inline-alien-setter? ]
|
[ fixnum inline-alien-setter? ]
|
||||||
inline-alien ; inline
|
inline-alien ; inline
|
||||||
|
|
||||||
: inline-alien-cell-setter ( node quot -- )
|
: inline-alien-cell-setter ( node quot -- )
|
||||||
[ dup node-input-infos first class>> ] dip
|
[ dup node-input-infos first class>> ] dip
|
||||||
'[ phantom-pop _ ^^unbox-c-ptr @ ]
|
'[ ds-pop _ ^^unbox-c-ptr @ ]
|
||||||
[ pinned-c-ptr inline-alien-setter? ]
|
[ pinned-c-ptr inline-alien-setter? ]
|
||||||
inline-alien ; inline
|
inline-alien ; inline
|
||||||
|
|
||||||
: inline-alien-float-setter ( node quot -- )
|
: inline-alien-float-setter ( node quot -- )
|
||||||
'[ phantom-pop ^^unbox-float @ ]
|
'[ ds-pop ^^unbox-float @ ]
|
||||||
[ float inline-alien-setter? ]
|
[ float inline-alien-setter? ]
|
||||||
inline-alien ; inline
|
inline-alien ; inline
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: kernel math math.order sequences accessors arrays
|
USING: kernel math math.order sequences accessors arrays
|
||||||
byte-arrays layouts classes.tuple.private fry locals
|
byte-arrays layouts classes.tuple.private fry locals
|
||||||
compiler.tree.propagation.info compiler.cfg.hats
|
compiler.tree.propagation.info compiler.cfg.hats
|
||||||
compiler.cfg.instructions compiler.cfg.stacks ;
|
compiler.cfg.instructions compiler.cfg.stacks
|
||||||
|
compiler.cfg.intrinsics.utilities ;
|
||||||
IN: compiler.cfg.intrinsics.allot
|
IN: compiler.cfg.intrinsics.allot
|
||||||
|
|
||||||
: ##set-slots ( regs obj class -- )
|
: ##set-slots ( regs obj class -- )
|
||||||
|
@ -11,16 +12,16 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
|
|
||||||
: emit-simple-allot ( node -- )
|
: emit-simple-allot ( node -- )
|
||||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||||
[ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
|
[ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
|
||||||
[ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ;
|
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
|
||||||
|
|
||||||
: tuple-slot-regs ( layout -- vregs )
|
: tuple-slot-regs ( layout -- vregs )
|
||||||
[ size>> phantom-load ] [ ^^load-literal ] bi prefix ;
|
[ size>> ds-load ] [ ^^load-literal ] bi prefix ;
|
||||||
|
|
||||||
:: emit-<tuple-boa> ( node -- )
|
:: emit-<tuple-boa> ( node -- )
|
||||||
[let | layout [ node node-input-infos peek literal>> ] |
|
[let | layout [ node node-input-infos peek literal>> ] |
|
||||||
layout tuple-layout? [
|
layout tuple-layout? [
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
layout tuple-slot-regs
|
layout tuple-slot-regs
|
||||||
layout size>> ^^allot-tuple
|
layout size>> ^^allot-tuple
|
||||||
tuple ##set-slots
|
tuple ##set-slots
|
||||||
|
@ -36,11 +37,11 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
:: emit-<array> ( node -- )
|
:: emit-<array> ( node -- )
|
||||||
[let | len [ node node-input-infos first literal>> ] |
|
[let | len [ node node-input-infos first literal>> ] |
|
||||||
len expand-<array>? [
|
len expand-<array>? [
|
||||||
[let | elt [ phantom-pop ]
|
[let | elt [ ds-pop ]
|
||||||
reg [ len ^^allot-array ] |
|
reg [ len ^^allot-array ] |
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
elt reg len store-initial-element
|
elt reg len store-initial-element
|
||||||
reg phantom-push
|
reg ds-push
|
||||||
]
|
]
|
||||||
] [ node emit-primitive ] if
|
] [ node emit-primitive ] if
|
||||||
] ;
|
] ;
|
||||||
|
@ -55,9 +56,9 @@ IN: compiler.cfg.intrinsics.allot
|
||||||
len expand-<byte-array>? [
|
len expand-<byte-array>? [
|
||||||
[let | elt [ 0 ^^load-literal ]
|
[let | elt [ 0 ^^load-literal ]
|
||||||
reg [ len ^^allot-byte-array ] |
|
reg [ len ^^allot-byte-array ] |
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
elt reg len bytes>cells store-initial-element
|
elt reg len bytes>cells store-initial-element
|
||||||
reg phantom-push
|
reg ds-push
|
||||||
]
|
]
|
||||||
] [ node emit-primitive ] if
|
] [ node emit-primitive ] if
|
||||||
] ;
|
] ;
|
||||||
|
|
|
@ -8,12 +8,12 @@ compiler.cfg.intrinsics.utilities ;
|
||||||
IN: compiler.cfg.intrinsics.fixnum
|
IN: compiler.cfg.intrinsics.fixnum
|
||||||
|
|
||||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
[ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
[ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
|
||||||
call ; inline
|
call ; inline
|
||||||
|
|
||||||
: (emit-fixnum-op) ( insn -- dst )
|
: (emit-fixnum-op) ( insn -- dst )
|
||||||
[ 2phantom-pop ] dip call ; inline
|
[ 2inputs ] dip call ; inline
|
||||||
|
|
||||||
:: emit-fixnum-op ( node insn imm-insn -- )
|
:: emit-fixnum-op ( node insn imm-insn -- )
|
||||||
[let | infos [ node node-input-infos ] |
|
[let | infos [ node node-input-infos ] |
|
||||||
|
@ -21,43 +21,43 @@ IN: compiler.cfg.intrinsics.fixnum
|
||||||
[ infos imm-insn (emit-fixnum-imm-op) ]
|
[ infos imm-insn (emit-fixnum-imm-op) ]
|
||||||
[ insn (emit-fixnum-op) ]
|
[ insn (emit-fixnum-op) ]
|
||||||
if
|
if
|
||||||
phantom-push
|
ds-push
|
||||||
] ; inline
|
] ; inline
|
||||||
|
|
||||||
: emit-fixnum-shift-fast ( node -- )
|
: emit-fixnum-shift-fast ( node -- )
|
||||||
dup node-input-infos dup second value-info-small-tagged? [
|
dup node-input-infos dup second value-info-small-tagged? [
|
||||||
nip
|
nip
|
||||||
[ 1 phantom-drop phantom-pop ] dip
|
[ ds-drop ds-pop ] dip
|
||||||
second literal>> dup sgn {
|
second literal>> dup sgn {
|
||||||
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
|
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
|
||||||
{ 0 [ drop ] }
|
{ 0 [ drop ] }
|
||||||
{ 1 [ ^^shl-imm ] }
|
{ 1 [ ^^shl-imm ] }
|
||||||
} case
|
} case
|
||||||
phantom-push
|
ds-push
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
: emit-fixnum-bitnot ( -- )
|
: emit-fixnum-bitnot ( -- )
|
||||||
phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
|
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
|
||||||
|
|
||||||
: (emit-fixnum*fast) ( -- dst )
|
: (emit-fixnum*fast) ( -- dst )
|
||||||
2phantom-pop ^^untag-fixnum ^^mul ;
|
2inputs ^^untag-fixnum ^^mul ;
|
||||||
|
|
||||||
: (emit-fixnum*fast-imm) ( infos -- dst )
|
: (emit-fixnum*fast-imm) ( infos -- dst )
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
[ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
|
[ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
|
||||||
|
|
||||||
: emit-fixnum*fast ( node -- )
|
: emit-fixnum*fast ( node -- )
|
||||||
node-input-infos
|
node-input-infos
|
||||||
dup second value-info-small-tagged?
|
dup second value-info-small-tagged?
|
||||||
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
|
||||||
phantom-push ;
|
ds-push ;
|
||||||
|
|
||||||
: emit-fixnum-comparison ( node cc -- )
|
: emit-fixnum-comparison ( node cc -- )
|
||||||
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
||||||
emit-fixnum-op ;
|
emit-fixnum-op ;
|
||||||
|
|
||||||
: emit-bignum>fixnum ( -- )
|
: emit-bignum>fixnum ( -- )
|
||||||
phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
|
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
|
||||||
|
|
||||||
: emit-fixnum>bignum ( -- )
|
: emit-fixnum>bignum ( -- )
|
||||||
phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
|
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||||
|
|
|
@ -4,15 +4,15 @@ USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
|
||||||
IN: compiler.cfg.intrinsics.float
|
IN: compiler.cfg.intrinsics.float
|
||||||
|
|
||||||
: emit-float-op ( insn -- )
|
: emit-float-op ( insn -- )
|
||||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
||||||
phantom-push ; inline
|
ds-push ; inline
|
||||||
|
|
||||||
: emit-float-comparison ( cc -- )
|
: emit-float-comparison ( cc -- )
|
||||||
[ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
||||||
phantom-push ; inline
|
ds-push ; inline
|
||||||
|
|
||||||
: emit-float>fixnum ( -- )
|
: emit-float>fixnum ( -- )
|
||||||
phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
|
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
|
||||||
|
|
||||||
: emit-fixnum>float ( -- )
|
: emit-fixnum>float ( -- )
|
||||||
phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
|
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
|
||||||
|
|
|
@ -7,17 +7,17 @@ compiler.cfg.intrinsics.utilities ;
|
||||||
IN: compiler.cfg.intrinsics.slots
|
IN: compiler.cfg.intrinsics.slots
|
||||||
|
|
||||||
: emit-tag ( -- )
|
: emit-tag ( -- )
|
||||||
phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
|
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||||
|
|
||||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||||
|
|
||||||
: (emit-slot) ( infos -- dst )
|
: (emit-slot) ( infos -- dst )
|
||||||
[ 2phantom-pop ] [ first value-tag ] bi*
|
[ 2inputs ] [ first value-tag ] bi*
|
||||||
^^slot ;
|
^^slot ;
|
||||||
|
|
||||||
: (emit-slot-imm) ( infos -- dst )
|
: (emit-slot-imm) ( infos -- dst )
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
[ phantom-pop ^^offset>slot ]
|
[ ds-pop ^^offset>slot ]
|
||||||
[ [ second literal>> ] [ first value-tag ] bi ] bi*
|
[ [ second literal>> ] [ first value-tag ] bi ] bi*
|
||||||
^^slot-imm ;
|
^^slot-imm ;
|
||||||
|
|
||||||
|
@ -27,17 +27,17 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
nip
|
nip
|
||||||
dup second value-info-small-tagged?
|
dup second value-info-small-tagged?
|
||||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||||
phantom-push
|
ds-push
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
: (emit-set-slot) ( infos -- obj-reg )
|
: (emit-set-slot) ( infos -- obj-reg )
|
||||||
[ 3phantom-pop [ tuck ] dip ^^offset>slot ]
|
[ 3inputs [ tuck ] dip ^^offset>slot ]
|
||||||
[ second value-tag ]
|
[ second value-tag ]
|
||||||
bi* ^^set-slot ;
|
bi* ^^set-slot ;
|
||||||
|
|
||||||
: (emit-set-slot-imm) ( infos -- obj-reg )
|
: (emit-set-slot-imm) ( infos -- obj-reg )
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
[ 2phantom-pop tuck ]
|
[ 2inputs tuck ]
|
||||||
[ [ third literal>> ] [ second value-tag ] bi ] bi*
|
[ [ third literal>> ] [ second value-tag ] bi ] bi*
|
||||||
##set-slot-imm ;
|
##set-slot-imm ;
|
||||||
|
|
||||||
|
@ -45,10 +45,10 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
dup node-input-infos
|
dup node-input-infos
|
||||||
dup second value-tag [
|
dup second value-tag [
|
||||||
nip
|
nip
|
||||||
1 phantom-drop
|
ds-drop
|
||||||
[
|
[
|
||||||
dup third value-info-small-tagged?
|
dup third value-info-small-tagged?
|
||||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||||
] [ first class>> immediate class<= ] bi
|
] [ first class>> immediate class<= ] bi
|
||||||
[ drop ] [ ^^write-barrier ] if
|
[ drop ] [ i i ##write-barrier ] if
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
|
@ -1,7 +1,11 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel math layouts cpu.architecture ;
|
USING: accessors kernel math layouts cpu.architecture
|
||||||
|
compiler.cfg.instructions ;
|
||||||
IN: compiler.cfg.intrinsics.utilities
|
IN: compiler.cfg.intrinsics.utilities
|
||||||
|
|
||||||
: value-info-small-tagged? ( value-info -- ? )
|
: value-info-small-tagged? ( value-info -- ? )
|
||||||
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
|
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: emit-primitive ( node -- )
|
||||||
|
word>> ##simple-stack-frame ##call ;
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
IN: compiler.cfg.linearization.tests
|
||||||
|
USING: compiler.cfg.linearization tools.test ;
|
||||||
|
|
||||||
|
\ build-mr must-infer
|
|
@ -16,7 +16,7 @@ TUPLE: ds-loc < loc ;
|
||||||
C: <ds-loc> ds-loc
|
C: <ds-loc> ds-loc
|
||||||
|
|
||||||
TUPLE: rs-loc < loc ;
|
TUPLE: rs-loc < loc ;
|
||||||
C: <rs-loc> ds-loc
|
C: <rs-loc> rs-loc
|
||||||
|
|
||||||
! Prettyprinting
|
! Prettyprinting
|
||||||
: V scan-word scan-word vreg boa parsed ; parsing
|
: V scan-word scan-word vreg boa parsed ; parsing
|
||||||
|
|
|
@ -1,201 +1,33 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs classes classes.private classes.algebra
|
USING: math sequences kernel cpu.architecture
|
||||||
combinators hashtables kernel layouts math fry namespaces
|
|
||||||
quotations sequences system vectors words effects alien
|
|
||||||
byte-arrays accessors sets math.order
|
|
||||||
combinators.short-circuit cpu.architecture
|
|
||||||
compiler.cfg.instructions compiler.cfg.registers
|
compiler.cfg.instructions compiler.cfg.registers
|
||||||
compiler.cfg.hats ;
|
compiler.cfg.hats ;
|
||||||
IN: compiler.cfg.stacks
|
IN: compiler.cfg.stacks
|
||||||
|
|
||||||
! Converting stack operations into register operations, while
|
: ds-drop ( -- )
|
||||||
! doing a bit of optimization along the way.
|
-1 ##inc-d ;
|
||||||
|
|
||||||
! A compile-time stack
|
: ds-pop ( -- vreg )
|
||||||
TUPLE: phantom-stack { height integer } { stack vector } ;
|
D 0 ^^peek -1 ##inc-d ;
|
||||||
|
|
||||||
M: phantom-stack clone
|
: ds-push ( vreg -- )
|
||||||
call-next-method [ clone ] change-stack ;
|
1 ##inc-d D 0 ##replace ;
|
||||||
|
|
||||||
GENERIC: finalize-height ( stack -- )
|
: ds-load ( n -- vregs )
|
||||||
|
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
|
||||||
|
|
||||||
: new-phantom-stack ( class -- stack )
|
: ds-store ( vregs -- )
|
||||||
new V{ } clone >>stack ; inline
|
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
|
||||||
|
|
||||||
: (loc) ( m stack -- n )
|
: rs-load ( n -- vregs )
|
||||||
#! Utility for methods on <loc>
|
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
|
||||||
height>> - ; inline
|
|
||||||
|
|
||||||
: (finalize-height) ( stack word -- )
|
: rs-store ( vregs -- )
|
||||||
#! We consolidate multiple stack height changes until the
|
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
|
||||||
#! last moment, and we emit the final height changing
|
|
||||||
#! instruction here.
|
|
||||||
'[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
|
|
||||||
|
|
||||||
GENERIC: <loc> ( n stack -- loc )
|
: 2inputs ( -- vreg1 vreg2 )
|
||||||
|
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
|
||||||
|
|
||||||
TUPLE: phantom-datastack < phantom-stack ;
|
: 3inputs ( -- vreg1 vreg2 vreg3 )
|
||||||
|
D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
|
||||||
: <phantom-datastack> ( -- stack )
|
|
||||||
phantom-datastack new-phantom-stack ;
|
|
||||||
|
|
||||||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
|
||||||
|
|
||||||
M: phantom-datastack finalize-height
|
|
||||||
\ ##inc-d (finalize-height) ;
|
|
||||||
|
|
||||||
TUPLE: phantom-retainstack < phantom-stack ;
|
|
||||||
|
|
||||||
: <phantom-retainstack> ( -- stack )
|
|
||||||
phantom-retainstack new-phantom-stack ;
|
|
||||||
|
|
||||||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
|
||||||
|
|
||||||
M: phantom-retainstack finalize-height
|
|
||||||
\ ##inc-r (finalize-height) ;
|
|
||||||
|
|
||||||
: phantom-locs ( n phantom -- locs )
|
|
||||||
#! A sequence of n ds-locs or rs-locs indexing the stack.
|
|
||||||
[ <reversed> ] dip '[ _ <loc> ] map ;
|
|
||||||
|
|
||||||
: phantom-locs* ( phantom -- locs )
|
|
||||||
[ stack>> length ] keep phantom-locs ;
|
|
||||||
|
|
||||||
: phantoms ( -- phantom phantom )
|
|
||||||
phantom-datastack get phantom-retainstack get ;
|
|
||||||
|
|
||||||
: (each-loc) ( phantom quot -- )
|
|
||||||
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
|
|
||||||
|
|
||||||
: each-loc ( quot -- )
|
|
||||||
phantoms 2array swap '[ _ (each-loc) ] each ; inline
|
|
||||||
|
|
||||||
: adjust-phantom ( n phantom -- )
|
|
||||||
swap '[ _ + ] change-height drop ;
|
|
||||||
|
|
||||||
: cut-phantom ( n phantom -- seq )
|
|
||||||
swap '[ _ cut* swap ] change-stack drop ;
|
|
||||||
|
|
||||||
: phantom-append ( seq stack -- )
|
|
||||||
over length over adjust-phantom stack>> push-all ;
|
|
||||||
|
|
||||||
: add-locs ( n phantom -- )
|
|
||||||
2dup stack>> length <= [
|
|
||||||
2drop
|
|
||||||
] [
|
|
||||||
[ phantom-locs ] keep
|
|
||||||
[ stack>> length head-slice* ] keep
|
|
||||||
[ append >vector ] change-stack drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: phantom-input ( n phantom -- seq )
|
|
||||||
2dup add-locs
|
|
||||||
2dup cut-phantom
|
|
||||||
>r >r neg r> adjust-phantom r> ;
|
|
||||||
|
|
||||||
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
|
|
||||||
|
|
||||||
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
|
|
||||||
|
|
||||||
GENERIC: lazy-load ( loc/vreg -- vreg )
|
|
||||||
M: loc lazy-load ^^peek ;
|
|
||||||
M: vreg lazy-load ;
|
|
||||||
|
|
||||||
GENERIC: live-loc? ( actual current -- ? )
|
|
||||||
M: vreg live-loc? 2drop f ;
|
|
||||||
M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
|
|
||||||
|
|
||||||
: (live-locs) ( phantom -- seq )
|
|
||||||
#! Discard locs which haven't moved
|
|
||||||
[ phantom-locs* ] [ stack>> ] bi zip
|
|
||||||
[ live-loc? ] assoc-filter
|
|
||||||
values ;
|
|
||||||
|
|
||||||
: live-locs ( -- seq )
|
|
||||||
[ (live-locs) ] each-phantom append prune ;
|
|
||||||
|
|
||||||
GENERIC: lazy-store ( dst src -- )
|
|
||||||
|
|
||||||
M: vreg lazy-store 2drop ;
|
|
||||||
|
|
||||||
M: loc lazy-store
|
|
||||||
2dup live-loc? [
|
|
||||||
\ live-locs get at swap ##replace
|
|
||||||
] [ 2drop ] if ;
|
|
||||||
|
|
||||||
: finalize-locs ( -- )
|
|
||||||
#! Perform any deferred stack shuffling.
|
|
||||||
live-locs [ dup lazy-load ] H{ } map>assoc
|
|
||||||
dup assoc-empty? [ drop ] [
|
|
||||||
\ live-locs set
|
|
||||||
[ lazy-store ] each-loc
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: finalize-vregs ( -- )
|
|
||||||
#! Store any vregs to their final stack locations.
|
|
||||||
[ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ;
|
|
||||||
|
|
||||||
: clear-phantoms ( -- )
|
|
||||||
[ stack>> delete-all ] each-phantom ;
|
|
||||||
|
|
||||||
: finalize-contents ( -- )
|
|
||||||
finalize-locs finalize-vregs clear-phantoms ;
|
|
||||||
|
|
||||||
! Loading stacks to vregs
|
|
||||||
: 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
|
|
||||||
finalize-heights
|
|
||||||
fresh-objects get [
|
|
||||||
empty? [ ##simple-stack-frame ##gc ] unless
|
|
||||||
] [ delete-all ] bi ;
|
|
||||||
|
|
||||||
: init-phantoms ( -- )
|
|
||||||
V{ } clone fresh-objects set
|
|
||||||
<phantom-datastack> phantom-datastack set
|
|
||||||
<phantom-retainstack> phantom-retainstack set ;
|
|
||||||
|
|
||||||
: copy-phantoms ( -- )
|
|
||||||
fresh-objects [ clone ] change
|
|
||||||
phantom-datastack [ clone ] change
|
|
||||||
phantom-retainstack [ clone ] change ;
|
|
||||||
|
|
||||||
: phantom-push ( obj -- )
|
|
||||||
1 phantom-datastack get adjust-phantom
|
|
||||||
phantom-datastack get stack>> push ;
|
|
||||||
|
|
||||||
: phantom-shuffle ( shuffle -- )
|
|
||||||
[ in>> length phantom-datastack get phantom-input ] keep
|
|
||||||
shuffle phantom-datastack get phantom-append ;
|
|
||||||
|
|
||||||
: phantom->r ( n -- )
|
|
||||||
phantom-datastack get phantom-input
|
|
||||||
phantom-retainstack get phantom-append ;
|
|
||||||
|
|
||||||
: phantom-r> ( n -- )
|
|
||||||
phantom-retainstack get phantom-input
|
|
||||||
phantom-datastack get phantom-append ;
|
|
||||||
|
|
||||||
: phantom-drop ( n -- )
|
|
||||||
phantom-datastack get phantom-input drop ;
|
|
||||||
|
|
||||||
: phantom-rdrop ( n -- )
|
|
||||||
phantom-retainstack get phantom-input drop ;
|
|
||||||
|
|
||||||
: phantom-load ( n -- vreg )
|
|
||||||
phantom-datastack get phantom-input [ lazy-load ] map ;
|
|
||||||
|
|
||||||
: phantom-pop ( -- vreg )
|
|
||||||
1 phantom-load first ;
|
|
||||||
|
|
||||||
: 2phantom-pop ( -- vreg1 vreg2 )
|
|
||||||
2 phantom-load first2 ;
|
|
||||||
|
|
||||||
: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
|
|
||||||
3 phantom-load first3 ;
|
|
||||||
|
|
||||||
: emit-primitive ( node -- )
|
|
||||||
finalize-phantoms word>> ##simple-stack-frame ##call ;
|
|
||||||
|
|
Loading…
Reference in New Issue