compiler.cfg.intrinsics.slots: refactor + docs & tests
Björn Lindqvist
parent
686975ec29
commit
02c80423ba
|
|
@ -1,6 +1,6 @@
|
|||
USING: classes classes.builtin compiler.cfg.instructions compiler.tree
|
||||
compiler.tree.propagation.info help.markup help.syntax math layouts sequences
|
||||
slots.private words ;
|
||||
USING: classes classes.builtin compiler.tree
|
||||
compiler.tree.propagation.info help.markup help.syntax layouts math
|
||||
slots.private ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
HELP: class-tag
|
||||
|
|
@ -26,15 +26,17 @@ HELP: immediate-slot-offset?
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: value-tag
|
||||
{ $values { "info" value-info-state } { "n" number } }
|
||||
{ $description "Finds the class number for this value-info-states class (an index in the " { $link builtins } " list), or " { $link f } " if it hasn't one." } ;
|
||||
HELP: node>set-slot-data
|
||||
{ $values
|
||||
{ "#call" #call }
|
||||
{ "write-barrier?" "whether a write barrier is needed, it always is unless the item to set is an " { $link immediate } }
|
||||
{ "tag" "a number or f" }
|
||||
{ "literal" "a literal" }
|
||||
} { $description "Grabs the data needed from a call node to determine what intrinsic CFG instructions to emit for the " { $link set-slot } " call." } ;
|
||||
|
||||
HELP: emit-write-barrier?
|
||||
{ $values { "infos" "a " { $link sequence } " of " { $link value-info-state } " tuples." } { "?" "true or false" } }
|
||||
{ $description
|
||||
"Whether a given call to " { $link set-slot } " requires a write barrier to be emitted or not. Write barriers are always needed except when the element to set in the slot is known by the compiler to be " { $link immediate } "." }
|
||||
{ $see-also ##write-barrier } ;
|
||||
HELP: value-tag
|
||||
{ $values { "info" value-info-state } { "n/f" number } }
|
||||
{ $description "Finds the class number for this value-info-states class (an index in the " { $link builtins } " list), or " { $link f } " if it hasn't one." } ;
|
||||
|
||||
HELP: emit-set-slot
|
||||
{ $values { "node" node } }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,170 @@
|
|||
USING: accessors arrays compiler.cfg compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics.slots compiler.test compiler.tree
|
||||
compiler.tree.propagation.info kernel make math math.intervals
|
||||
namespaces sequences slots.private tools.test ;
|
||||
IN: compiler.cfg.intrinsics.slots.tests
|
||||
|
||||
: call-node-1 ( -- node )
|
||||
T{ #call
|
||||
{ word set-slot }
|
||||
{ in-d V{ 9133848 9133849 9133850 } }
|
||||
{ out-d { } }
|
||||
{ info
|
||||
H{
|
||||
{
|
||||
9133848
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
9133849
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
9133850
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
: call-node-2 ( -- node )
|
||||
T{ #call
|
||||
{ word set-slot }
|
||||
{ in-d V{ 1 2 3 } }
|
||||
{ out-d { } }
|
||||
{ info
|
||||
H{
|
||||
{
|
||||
1
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
2
|
||||
T{ value-info-state
|
||||
{ class array }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
3
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
: call-node-3 ( -- node )
|
||||
T{ #call
|
||||
{ word set-slot }
|
||||
{ in-d V{ 1 2 3 } }
|
||||
{ out-d { } }
|
||||
{ info
|
||||
H{
|
||||
{
|
||||
1
|
||||
T{ value-info-state
|
||||
{ class object }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
2
|
||||
T{ value-info-state
|
||||
{ class array }
|
||||
{ interval full-interval }
|
||||
}
|
||||
}
|
||||
{
|
||||
3
|
||||
T{ value-info-state
|
||||
{ class fixnum }
|
||||
{ interval
|
||||
T{ interval
|
||||
{ from { 9 t } }
|
||||
{ to { 9 t } }
|
||||
}
|
||||
}
|
||||
{ literal 9 }
|
||||
{ literal? t }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
! emit-set-slot
|
||||
{
|
||||
V{ T{ ##call { word set-slot } } T{ ##branch } }
|
||||
} [
|
||||
call-node-1 [ emit-set-slot ] V{ } make drop
|
||||
basic-block get successors>> first instructions>>
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
V{
|
||||
T{ ##set-slot
|
||||
{ src 1 }
|
||||
{ obj 2 }
|
||||
{ slot 3 }
|
||||
{ scale 3 }
|
||||
{ tag 2 }
|
||||
}
|
||||
T{ ##write-barrier
|
||||
{ src 2 }
|
||||
{ slot 3 }
|
||||
{ scale 3 }
|
||||
{ tag 2 }
|
||||
{ temp1 4 }
|
||||
{ temp2 5 }
|
||||
}
|
||||
}
|
||||
} [
|
||||
call-node-2 [ emit-set-slot ] V{ } make
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
V{
|
||||
T{ ##set-slot-imm { src 1 } { obj 2 } { slot 9 } { tag 2 } }
|
||||
T{ ##write-barrier-imm
|
||||
{ src 2 }
|
||||
{ slot 9 }
|
||||
{ tag 2 }
|
||||
{ temp1 3 }
|
||||
{ temp2 4 }
|
||||
}
|
||||
}
|
||||
} [
|
||||
call-node-3 [ emit-set-slot ] V{ } make
|
||||
] cfg-unit-test
|
||||
|
||||
! immediate-slot-offset?
|
||||
{ t f } [
|
||||
33 immediate-slot-offset?
|
||||
"foo" immediate-slot-offset?
|
||||
] unit-test
|
||||
|
||||
! node>set-slot-data
|
||||
{
|
||||
t f f
|
||||
t 2 f
|
||||
t 2 9
|
||||
} [
|
||||
call-node-1 node>set-slot-data
|
||||
call-node-2 node>set-slot-data
|
||||
call-node-3 node>set-slot-data
|
||||
] unit-test
|
||||
|
|
@ -2,16 +2,16 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes.algebra classes.builtin
|
||||
combinators.short-circuit compiler.cfg.builder.blocks
|
||||
compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stacks
|
||||
compiler.tree.propagation.info cpu.architecture kernel layouts
|
||||
locals math namespaces sequences ;
|
||||
compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture
|
||||
kernel layouts locals math namespaces sequences slots.private ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: class-tag ( class -- tag/f )
|
||||
builtins get [ class<= ] with find drop ;
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ;
|
||||
: value-tag ( info -- n/f )
|
||||
class>> class-tag ;
|
||||
|
||||
: slot-indexing ( slot tag -- slot scale tag )
|
||||
complex-addressing?
|
||||
|
|
@ -27,52 +27,48 @@ IN: compiler.cfg.intrinsics.slots
|
|||
[ [ second literal>> ] [ first value-tag ] bi ] bi*
|
||||
^^slot-imm ;
|
||||
|
||||
: immediate-slot-offset? ( value-info -- ? )
|
||||
literal>> {
|
||||
[ fixnum? ]
|
||||
[ cell * immediate-arithmetic? ]
|
||||
} 1&& ;
|
||||
: immediate-slot-offset? ( object -- ? )
|
||||
{ [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ;
|
||||
|
||||
: emit-slot ( node -- )
|
||||
dup node-input-infos
|
||||
dup first value-tag [
|
||||
nip
|
||||
dup second immediate-slot-offset?
|
||||
dup second literal>> immediate-slot-offset?
|
||||
[ (emit-slot-imm) ] [ (emit-slot) ] if
|
||||
ds-push
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-write-barrier? ( infos -- ? )
|
||||
first class>> immediate class<= not ;
|
||||
|
||||
:: (emit-set-slot) ( infos -- )
|
||||
3inputs :> ( src obj slot )
|
||||
|
||||
infos second value-tag :> tag
|
||||
|
||||
slot tag slot-indexing :> ( slot scale tag )
|
||||
src obj slot scale tag ##set-slot,
|
||||
|
||||
infos emit-write-barrier?
|
||||
[ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ;
|
||||
|
||||
:: (emit-set-slot-imm) ( infos -- )
|
||||
:: (emit-set-slot-imm) ( write-barrier? tag slot -- )
|
||||
ds-drop
|
||||
|
||||
2inputs :> ( src obj )
|
||||
|
||||
infos third literal>> :> slot
|
||||
infos second value-tag :> tag
|
||||
|
||||
src obj slot tag ##set-slot-imm,
|
||||
|
||||
infos emit-write-barrier?
|
||||
write-barrier?
|
||||
[ obj slot tag next-vreg next-vreg ##write-barrier-imm, ] when ;
|
||||
|
||||
:: (emit-set-slot) ( write-barrier? tag -- )
|
||||
3inputs :> ( src obj slot )
|
||||
|
||||
slot tag slot-indexing :> ( slot scale tag )
|
||||
|
||||
src obj slot scale tag ##set-slot,
|
||||
|
||||
write-barrier?
|
||||
[ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ;
|
||||
|
||||
: node>set-slot-data ( #call -- write-barrier? tag literal )
|
||||
node-input-infos first3
|
||||
[ class>> immediate class<= not ] [ value-tag ] [ literal>> ] tri* ;
|
||||
|
||||
: emit-intrinsic-set-slot ( write-barrier? tag index-info -- )
|
||||
dup immediate-slot-offset? [
|
||||
(emit-set-slot-imm)
|
||||
] [ drop (emit-set-slot) ] if ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
dup node-input-infos
|
||||
dup second value-tag [
|
||||
nip
|
||||
dup third immediate-slot-offset?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||
] [ drop emit-primitive ] if ;
|
||||
dup node>set-slot-data over [
|
||||
emit-intrinsic-set-slot drop
|
||||
] [ 3drop emit-primitive ] if ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue