95 lines
2.8 KiB
Factor
95 lines
2.8 KiB
Factor
! Copyright (C) 2011 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs bit-arrays classes.tuple combinators
|
|
combinators.short-circuit compiler.cfg.instructions
|
|
compiler.codegen.relocation cpu.architecture fry kernel layouts
|
|
make math math.order namespaces sequences sequences.generalizations ;
|
|
IN: compiler.codegen.gc-maps
|
|
|
|
SYMBOLS: return-addresses gc-maps ;
|
|
|
|
: gc-map-needed? ( gc-map/f -- ? )
|
|
! If there are no stack locations to scrub or check, and no GC
|
|
! roots, there's no point storing the GC map.
|
|
dup [ tuple-slots [ empty? ] all? not ] when ;
|
|
|
|
: gc-map-here ( gc-map -- )
|
|
dup gc-map-needed? [
|
|
gc-maps get push
|
|
compiled-offset return-addresses get push
|
|
] [ drop ] if ;
|
|
|
|
: emit-scrub ( seqs -- n )
|
|
! seqs is a sequence of sequences of 0/1
|
|
dup longest length
|
|
[ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
|
|
|
|
: integers>bits ( seq n -- bit-array )
|
|
<bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
|
|
|
|
: largest-spill-slot ( seqs -- n )
|
|
[ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
|
|
|
|
: emit-gc-roots ( seqs -- n )
|
|
! seqs is a sequence of sequences of integers 0..n-1
|
|
dup largest-spill-slot
|
|
[ '[ _ integers>bits % ] each ] keep ;
|
|
|
|
: emit-uint ( n -- )
|
|
building get push-uint ;
|
|
|
|
: emit-uints ( n -- )
|
|
[ emit-uint ] each ;
|
|
|
|
: gc-root-offsets ( gc-map -- offsets )
|
|
gc-roots>> [ gc-root-offset ] map ;
|
|
|
|
: emit-gc-info-bitmaps ( -- scrub-and-check-counts )
|
|
[
|
|
gc-maps get {
|
|
[ [ scrub-d>> ] map emit-scrub ]
|
|
[ [ scrub-r>> ] map emit-scrub ]
|
|
[ [ check-d>> ] map emit-scrub ]
|
|
[ [ check-r>> ] map emit-scrub ]
|
|
[ [ gc-root-offsets ] map emit-gc-roots ]
|
|
} cleave 5 narray
|
|
] ?{ } make underlying>> % ;
|
|
|
|
: emit-base-table ( alist longest -- )
|
|
-1 <array> <enum> swap assoc-union! seq>> emit-uints ;
|
|
|
|
: derived-root-offsets ( gc-map -- offsets )
|
|
derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
|
|
|
|
: emit-base-tables ( -- count )
|
|
gc-maps get [ derived-root-offsets ] map
|
|
dup [ keys ] map largest-spill-slot
|
|
[ '[ _ emit-base-table ] each ] keep ;
|
|
|
|
: emit-return-addresses ( -- )
|
|
return-addresses get emit-uints ;
|
|
|
|
: serialize-gc-maps ( -- byte-array )
|
|
[
|
|
return-addresses get empty? [ 0 emit-uint ] [
|
|
emit-gc-info-bitmaps
|
|
emit-base-tables suffix
|
|
emit-return-addresses
|
|
emit-uints
|
|
return-addresses get length emit-uint
|
|
] if
|
|
] B{ } make ;
|
|
|
|
: init-gc-maps ( -- )
|
|
V{ } clone return-addresses set
|
|
V{ } clone gc-maps set ;
|
|
|
|
: emit-gc-maps ( -- )
|
|
! We want to place the GC maps so that the end is aligned
|
|
! on a 16-byte boundary.
|
|
serialize-gc-maps [
|
|
length compiled-offset +
|
|
[ data-alignment get align ] keep -
|
|
(align-code)
|
|
] [ % ] bi ;
|