steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.cfg.intrinsics.slots: refactor + docs & tests

db4
Björn Lindqvist 2015-11-28 01:55:12 +01:00
parent 686975ec29
commit 02c80423ba
3 changed files with 215 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
basis/compiler/cfg/intrinsics/slots/slots-docs.factor
View File

@ -1,6 +1,6 @@
USING: classes classes.builtin compiler.cfg.instructions compiler.tree USING: classes classes.builtin compiler.tree
compiler.tree.propagation.info help.markup help.syntax math layouts sequences compiler.tree.propagation.info help.markup help.syntax layouts math
slots.private words ; slots.private ;
IN: compiler.cfg.intrinsics.slots IN: compiler.cfg.intrinsics.slots
HELP: class-tag HELP: class-tag
@ -26,15 +26,17 @@ HELP: immediate-slot-offset?
} }
} ; } ;
HELP: value-tag HELP: node>set-slot-data
{ $values { "info" value-info-state } { "n" number } } { $values
{ $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." } ; { "#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? HELP: value-tag
{ $values { "infos" "a " { $link sequence } " of " { $link value-info-state } " tuples." } { "?" "true or false" } } { $values { "info" value-info-state } { "n/f" number } }
{ $description { $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." } ;
"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: emit-set-slot HELP: emit-set-slot
{ $values { "node" node } } { $values { "node" node } }

170
basis/compiler/cfg/intrinsics/slots/slots-tests.factor Normal file
View File

@ -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

68
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -2,16 +2,16 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.algebra classes.builtin USING: accessors classes.algebra classes.builtin
combinators.short-circuit compiler.cfg.builder.blocks combinators.short-circuit compiler.cfg.builder.blocks
compiler.cfg.hats compiler.cfg.instructions compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks compiler.tree.propagation.info cpu.architecture
compiler.tree.propagation.info cpu.architecture kernel layouts kernel layouts locals math namespaces sequences slots.private ;
locals math namespaces sequences ;
IN: compiler.cfg.intrinsics.slots IN: compiler.cfg.intrinsics.slots
: class-tag ( class -- tag/f ) : class-tag ( class -- tag/f )
builtins get [ class<= ] with find drop ; 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 ) : slot-indexing ( slot tag -- slot scale tag )
complex-addressing? complex-addressing?
@ -27,52 +27,48 @@ IN: compiler.cfg.intrinsics.slots
[ [ second literal>> ] [ first value-tag ] bi ] bi* [ [ second literal>> ] [ first value-tag ] bi ] bi*
^^slot-imm ; ^^slot-imm ;
: immediate-slot-offset? ( value-info -- ? ) : immediate-slot-offset? ( object -- ? )
literal>> { { [ fixnum? ] [ cell * immediate-arithmetic? ] } 1&& ;
[ fixnum? ]
[ cell * immediate-arithmetic? ]
} 1&& ;
: emit-slot ( node -- ) : emit-slot ( node -- )
dup node-input-infos dup node-input-infos
dup first value-tag [ dup first value-tag [
nip nip
dup second immediate-slot-offset? dup second literal>> immediate-slot-offset?
[ (emit-slot-imm) ] [ (emit-slot) ] if [ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push ds-push
] [ drop emit-primitive ] if ; ] [ drop emit-primitive ] if ;
: emit-write-barrier? ( infos -- ? ) :: (emit-set-slot-imm) ( write-barrier? tag slot -- )
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 -- )
ds-drop ds-drop
2inputs :> ( src obj ) 2inputs :> ( src obj )
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? 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) ( 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 -- ) : emit-set-slot ( node -- )
dup node-input-infos dup node>set-slot-data over [
dup second value-tag [ emit-intrinsic-set-slot drop
nip ] [ 3drop emit-primitive ] if ;
dup third immediate-slot-offset?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ drop emit-primitive ] if ;