Split up compiler.codegen.fixup into compiler.codegen.{gc-maps,labels,relocation}
Slava Pestov
parent
c68e2308a8
commit
b89e9a549b
|
|
@ -1,5 +1,6 @@
|
||||||
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
|
USING: compiler.codegen compiler.codegen.labels
|
||||||
compiler.constants words ;
|
compiler.codegen.relocation tools.test cpu.architecture math
|
||||||
|
kernel make compiler.constants words ;
|
||||||
IN: compiler.codegen.tests
|
IN: compiler.codegen.tests
|
||||||
|
|
||||||
[ ] [ [ ] with-fixup drop ] unit-test
|
[ ] [ [ ] with-fixup drop ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
! Copyright (C) 2008, 2011 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces make math math.order math.parser sequences
|
USING: byte-arrays namespaces make math math.order math.parser
|
||||||
accessors kernel layouts assocs words summary arrays combinators
|
sequences accessors kernel layouts assocs words summary arrays
|
||||||
classes.algebra sets continuations.private fry cpu.architecture
|
combinators combinators.smart sets continuations.private fry
|
||||||
classes classes.struct locals slots parser generic.parser
|
cpu.architecture classes classes.struct locals slots parser
|
||||||
strings quotations hashtables
|
generic.parser strings quotations hashtables
|
||||||
compiler.constants
|
compiler.constants
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
compiler.cfg.linearization
|
compiler.cfg.linearization
|
||||||
|
|
@ -13,7 +13,9 @@ compiler.cfg.comparisons
|
||||||
compiler.cfg.stack-frame
|
compiler.cfg.stack-frame
|
||||||
compiler.cfg.registers
|
compiler.cfg.registers
|
||||||
compiler.cfg.builder
|
compiler.cfg.builder
|
||||||
compiler.codegen.fixup
|
compiler.codegen.gc-maps
|
||||||
|
compiler.codegen.labels
|
||||||
|
compiler.codegen.relocation
|
||||||
compiler.utilities ;
|
compiler.utilities ;
|
||||||
FROM: namespaces => set ;
|
FROM: namespaces => set ;
|
||||||
IN: compiler.codegen
|
IN: compiler.codegen
|
||||||
|
|
@ -81,6 +83,31 @@ M: ##dispatch generate-insn
|
||||||
] each
|
] each
|
||||||
] tri ;
|
] tri ;
|
||||||
|
|
||||||
|
: init-fixup ( -- )
|
||||||
|
V{ } clone label-table set
|
||||||
|
V{ } clone binary-literal-table set ;
|
||||||
|
|
||||||
|
: check-fixup ( seq -- )
|
||||||
|
length data-alignment get mod 0 assert= ;
|
||||||
|
|
||||||
|
: with-fixup ( quot -- code )
|
||||||
|
'[
|
||||||
|
init-relocation
|
||||||
|
init-gc-maps
|
||||||
|
init-fixup
|
||||||
|
[
|
||||||
|
@
|
||||||
|
emit-binary-literals
|
||||||
|
emit-gc-maps
|
||||||
|
label-table [ compute-labels ] change
|
||||||
|
parameter-table get >array
|
||||||
|
literal-table get >array
|
||||||
|
relocation-table get >byte-array
|
||||||
|
label-table get
|
||||||
|
] B{ } make
|
||||||
|
dup check-fixup
|
||||||
|
] output>array ; inline
|
||||||
|
|
||||||
: generate ( cfg -- code )
|
: generate ( cfg -- code )
|
||||||
[
|
[
|
||||||
H{ } clone labels set
|
H{ } clone labels set
|
||||||
|
|
|
||||||
|
|
@ -1,275 +0,0 @@
|
||||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
|
|
||||||
hashtables io.binary kernel kernel.private math namespaces make
|
|
||||||
sequences words quotations strings sorting alien.accessors
|
|
||||||
alien.strings layouts system combinators math.bitwise math.order
|
|
||||||
combinators.short-circuit combinators.smart accessors growable
|
|
||||||
fry memoize compiler.constants compiler.cfg.instructions
|
|
||||||
cpu.architecture ;
|
|
||||||
IN: compiler.codegen.fixup
|
|
||||||
|
|
||||||
! Utilities
|
|
||||||
: push-uint ( value vector -- )
|
|
||||||
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
|
|
||||||
swap set-alien-unsigned-4 ;
|
|
||||||
|
|
||||||
! Parameter table
|
|
||||||
SYMBOL: parameter-table
|
|
||||||
|
|
||||||
: add-parameter ( obj -- ) parameter-table get push ;
|
|
||||||
|
|
||||||
! Literal table
|
|
||||||
SYMBOL: literal-table
|
|
||||||
|
|
||||||
: add-literal ( obj -- ) literal-table get push ;
|
|
||||||
|
|
||||||
! Labels
|
|
||||||
SYMBOL: label-table
|
|
||||||
|
|
||||||
TUPLE: label offset ;
|
|
||||||
|
|
||||||
: <label> ( -- label ) label new ;
|
|
||||||
: define-label ( name -- ) <label> swap set ;
|
|
||||||
|
|
||||||
: compiled-offset ( -- n ) building get length ;
|
|
||||||
|
|
||||||
: resolve-label ( label/name -- )
|
|
||||||
dup label? [ get ] unless
|
|
||||||
compiled-offset >>offset drop ;
|
|
||||||
|
|
||||||
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
|
|
||||||
|
|
||||||
: label-fixup ( label class -- )
|
|
||||||
compiled-offset \ label-fixup boa label-table get push ;
|
|
||||||
|
|
||||||
! Relocation table
|
|
||||||
SYMBOL: relocation-table
|
|
||||||
|
|
||||||
: add-relocation-entry ( type class offset -- )
|
|
||||||
{ 0 24 28 } bitfield relocation-table get push-uint ;
|
|
||||||
|
|
||||||
: rel-fixup ( class type -- )
|
|
||||||
swap compiled-offset add-relocation-entry ;
|
|
||||||
|
|
||||||
! Binary literal table
|
|
||||||
SYMBOL: binary-literal-table
|
|
||||||
|
|
||||||
: add-binary-literal ( obj -- label )
|
|
||||||
<label> [ 2array binary-literal-table get push ] keep ;
|
|
||||||
|
|
||||||
! Caching common symbol names reduces image size a bit
|
|
||||||
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
|
|
||||||
|
|
||||||
: add-dlsym-parameters ( symbol dll -- )
|
|
||||||
[ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
|
|
||||||
|
|
||||||
: rel-dlsym ( name dll class -- )
|
|
||||||
[ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
|
|
||||||
|
|
||||||
: rel-dlsym-toc ( name dll class -- )
|
|
||||||
[ add-dlsym-parameters ] dip rt-dlsym-toc rel-fixup ;
|
|
||||||
|
|
||||||
: rel-word ( word class -- )
|
|
||||||
[ add-literal ] dip rt-entry-point rel-fixup ;
|
|
||||||
|
|
||||||
: rel-word-pic ( word class -- )
|
|
||||||
[ add-literal ] dip rt-entry-point-pic rel-fixup ;
|
|
||||||
|
|
||||||
: rel-word-pic-tail ( word class -- )
|
|
||||||
[ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
|
|
||||||
|
|
||||||
: rel-literal ( literal class -- )
|
|
||||||
[ add-literal ] dip rt-literal rel-fixup ;
|
|
||||||
|
|
||||||
: rel-binary-literal ( literal class -- )
|
|
||||||
[ add-binary-literal ] dip label-fixup ;
|
|
||||||
|
|
||||||
: rel-this ( class -- )
|
|
||||||
rt-this rel-fixup ;
|
|
||||||
|
|
||||||
: rel-here ( offset class -- )
|
|
||||||
[ add-literal ] dip rt-here rel-fixup ;
|
|
||||||
|
|
||||||
: rel-vm ( offset class -- )
|
|
||||||
[ add-parameter ] dip rt-vm rel-fixup ;
|
|
||||||
|
|
||||||
: rel-cards-offset ( class -- )
|
|
||||||
rt-cards-offset rel-fixup ;
|
|
||||||
|
|
||||||
: rel-decks-offset ( class -- )
|
|
||||||
rt-decks-offset rel-fixup ;
|
|
||||||
|
|
||||||
! Labels
|
|
||||||
: compute-target ( label-fixup -- offset )
|
|
||||||
label>> offset>> [ "Unresolved label" throw ] unless* ;
|
|
||||||
|
|
||||||
: compute-relative-label ( label-fixup -- label )
|
|
||||||
[ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
|
|
||||||
|
|
||||||
: compute-absolute-label ( label-fixup -- )
|
|
||||||
[ compute-target neg add-literal ]
|
|
||||||
[ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
|
|
||||||
|
|
||||||
: compute-labels ( label-fixups -- labels' )
|
|
||||||
[ class>> rc-absolute? ] partition
|
|
||||||
[ [ compute-absolute-label ] each ]
|
|
||||||
[ [ compute-relative-label ] map concat ]
|
|
||||||
bi* ;
|
|
||||||
|
|
||||||
! Binary literals
|
|
||||||
: alignment ( align -- n )
|
|
||||||
[ compiled-offset dup ] dip align swap - ;
|
|
||||||
|
|
||||||
: (align-code) ( n -- )
|
|
||||||
0 <repetition> % ;
|
|
||||||
|
|
||||||
: align-code ( n -- )
|
|
||||||
alignment (align-code) ;
|
|
||||||
|
|
||||||
: emit-data ( obj label -- )
|
|
||||||
over length align-code
|
|
||||||
resolve-label
|
|
||||||
building get push-all ;
|
|
||||||
|
|
||||||
: emit-binary-literals ( -- )
|
|
||||||
binary-literal-table get [ emit-data ] assoc-each ;
|
|
||||||
|
|
||||||
! GC info
|
|
||||||
|
|
||||||
! Every code block either ends with
|
|
||||||
!
|
|
||||||
! uint 0
|
|
||||||
!
|
|
||||||
! or
|
|
||||||
!
|
|
||||||
! bitmap, byte aligned, three subsequences:
|
|
||||||
! - <scrubbed data stack locations>
|
|
||||||
! - <scrubbed retain stack locations>
|
|
||||||
! - <GC root spill slots>
|
|
||||||
! uint[] <base pointers>
|
|
||||||
! uint[] <return addresses>
|
|
||||||
! uint <largest scrubbed data stack location>
|
|
||||||
! uint <largest scrubbed retain stack location>
|
|
||||||
! uint <largest GC root spill slot>
|
|
||||||
! uint <largest derived root spill slot>
|
|
||||||
! int <number of return addresses>
|
|
||||||
!
|
|
||||||
SYMBOLS: return-addresses gc-maps ;
|
|
||||||
|
|
||||||
: gc-map-needed? ( gc-map -- ? )
|
|
||||||
! If there are no stack locations to scrub and no GC roots,
|
|
||||||
! there's no point storing the GC map.
|
|
||||||
dup [
|
|
||||||
{
|
|
||||||
[ scrub-d>> empty? ]
|
|
||||||
[ scrub-r>> empty? ]
|
|
||||||
[ gc-roots>> empty? ]
|
|
||||||
[ derived-roots>> empty? ]
|
|
||||||
} 1&& not
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: gc-map-here ( gc-map -- )
|
|
||||||
dup gc-map-needed? [
|
|
||||||
gc-maps get push
|
|
||||||
compiled-offset return-addresses get push
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
: longest ( seqs -- n )
|
|
||||||
[ length ] [ max ] map-reduce ;
|
|
||||||
|
|
||||||
: emit-scrub ( seqs -- n )
|
|
||||||
! seqs is a sequence of sequences of 0/1
|
|
||||||
dup longest
|
|
||||||
[ '[ [ 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-d-count scrub-r-count gc-root-count )
|
|
||||||
[
|
|
||||||
gc-maps get {
|
|
||||||
[ [ scrub-d>> ] map emit-scrub ]
|
|
||||||
[ [ scrub-r>> ] map emit-scrub ]
|
|
||||||
[ [ gc-root-offsets ] map emit-gc-roots ]
|
|
||||||
} cleave
|
|
||||||
] ?{ } 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 ;
|
|
||||||
|
|
||||||
: gc-info ( -- byte-array )
|
|
||||||
[
|
|
||||||
return-addresses get empty? [ 0 emit-uint ] [
|
|
||||||
emit-gc-info-bitmaps
|
|
||||||
emit-base-tables
|
|
||||||
emit-return-addresses
|
|
||||||
4array emit-uints
|
|
||||||
return-addresses get length emit-uint
|
|
||||||
] if
|
|
||||||
] B{ } make ;
|
|
||||||
|
|
||||||
: emit-gc-info ( -- )
|
|
||||||
! We want to place the GC info so that the end is aligned
|
|
||||||
! on a 16-byte boundary.
|
|
||||||
gc-info [
|
|
||||||
length compiled-offset +
|
|
||||||
[ data-alignment get align ] keep -
|
|
||||||
(align-code)
|
|
||||||
] [ % ] bi ;
|
|
||||||
|
|
||||||
: init-fixup ( -- )
|
|
||||||
V{ } clone parameter-table set
|
|
||||||
V{ } clone literal-table set
|
|
||||||
V{ } clone label-table set
|
|
||||||
BV{ } clone relocation-table set
|
|
||||||
V{ } clone binary-literal-table set
|
|
||||||
V{ } clone return-addresses set
|
|
||||||
V{ } clone gc-maps set ;
|
|
||||||
|
|
||||||
: check-fixup ( seq -- )
|
|
||||||
length data-alignment get mod 0 assert= ;
|
|
||||||
|
|
||||||
: with-fixup ( quot -- code )
|
|
||||||
'[
|
|
||||||
init-fixup
|
|
||||||
[
|
|
||||||
@
|
|
||||||
emit-binary-literals
|
|
||||||
emit-gc-info
|
|
||||||
label-table [ compute-labels ] change
|
|
||||||
parameter-table get >array
|
|
||||||
literal-table get >array
|
|
||||||
relocation-table get >byte-array
|
|
||||||
label-table get
|
|
||||||
] B{ } make
|
|
||||||
dup check-fixup
|
|
||||||
] output>array ; inline
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
USING: namespaces byte-arrays make compiler.codegen.fixup
|
USING: namespaces byte-arrays make compiler.codegen.gc-maps
|
||||||
bit-arrays accessors classes.struct tools.test kernel math
|
bit-arrays accessors classes.struct tools.test kernel math
|
||||||
sequences alien.c-types specialized-arrays boxes
|
sequences alien.c-types specialized-arrays boxes
|
||||||
compiler.cfg.instructions system cpu.architecture ;
|
compiler.cfg.instructions system cpu.architecture ;
|
||||||
SPECIALIZED-ARRAY: uint
|
SPECIALIZED-ARRAY: uint
|
||||||
IN: compiler.codegen.fixup.tests
|
IN: compiler.codegen.gc-maps.tests
|
||||||
|
|
||||||
STRUCT: gc-info
|
STRUCT: gc-info
|
||||||
{ scrub-d-count uint }
|
{ scrub-d-count uint }
|
||||||
|
|
@ -20,7 +20,7 @@ M: fake-cpu gc-root-offset ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
init-fixup
|
init-gc-maps
|
||||||
|
|
||||||
50 <byte-array> %
|
50 <byte-array> %
|
||||||
|
|
||||||
|
|
@ -30,7 +30,7 @@ M: fake-cpu gc-root-offset ;
|
||||||
|
|
||||||
T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
|
T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
|
||||||
|
|
||||||
emit-gc-info
|
emit-gc-maps
|
||||||
] B{ } make
|
] B{ } make
|
||||||
"result" set
|
"result" set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
@ -0,0 +1,122 @@
|
||||||
|
! Copyright (C) 2011 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs bit-arrays combinators
|
||||||
|
combinators.short-circuit compiler.cfg.instructions
|
||||||
|
compiler.codegen.relocation cpu.architecture fry kernel layouts
|
||||||
|
make math math.order namespaces sequences ;
|
||||||
|
IN: compiler.codegen.gc-maps
|
||||||
|
|
||||||
|
! GC maps
|
||||||
|
|
||||||
|
! Every code block either ends with
|
||||||
|
!
|
||||||
|
! uint 0
|
||||||
|
!
|
||||||
|
! or
|
||||||
|
!
|
||||||
|
! bitmap, byte aligned, three subsequences:
|
||||||
|
! - <scrubbed data stack locations>
|
||||||
|
! - <scrubbed retain stack locations>
|
||||||
|
! - <GC root spill slots>
|
||||||
|
! uint[] <base pointers>
|
||||||
|
! uint[] <return addresses>
|
||||||
|
! uint <largest scrubbed data stack location>
|
||||||
|
! uint <largest scrubbed retain stack location>
|
||||||
|
! uint <largest GC root spill slot>
|
||||||
|
! uint <largest derived root spill slot>
|
||||||
|
! int <number of return addresses>
|
||||||
|
|
||||||
|
SYMBOLS: return-addresses gc-maps ;
|
||||||
|
|
||||||
|
: gc-map-needed? ( gc-map -- ? )
|
||||||
|
! If there are no stack locations to scrub and no GC roots,
|
||||||
|
! there's no point storing the GC map.
|
||||||
|
dup [
|
||||||
|
{
|
||||||
|
[ scrub-d>> empty? ]
|
||||||
|
[ scrub-r>> empty? ]
|
||||||
|
[ gc-roots>> empty? ]
|
||||||
|
[ derived-roots>> empty? ]
|
||||||
|
} 1&& not
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: gc-map-here ( gc-map -- )
|
||||||
|
dup gc-map-needed? [
|
||||||
|
gc-maps get push
|
||||||
|
compiled-offset return-addresses get push
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: longest ( seqs -- n )
|
||||||
|
[ length ] [ max ] map-reduce ;
|
||||||
|
|
||||||
|
: emit-scrub ( seqs -- n )
|
||||||
|
! seqs is a sequence of sequences of 0/1
|
||||||
|
dup longest
|
||||||
|
[ '[ [ 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-d-count scrub-r-count gc-root-count )
|
||||||
|
[
|
||||||
|
gc-maps get {
|
||||||
|
[ [ scrub-d>> ] map emit-scrub ]
|
||||||
|
[ [ scrub-r>> ] map emit-scrub ]
|
||||||
|
[ [ gc-root-offsets ] map emit-gc-roots ]
|
||||||
|
} cleave
|
||||||
|
] ?{ } 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
|
||||||
|
emit-return-addresses
|
||||||
|
4array 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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,55 @@
|
||||||
|
! Copyright (C) 2007, 2011 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors arrays assocs compiler.codegen.relocation
|
||||||
|
compiler.constants kernel make math namespaces sequences ;
|
||||||
|
IN: compiler.codegen.labels
|
||||||
|
|
||||||
|
! Labels
|
||||||
|
SYMBOL: label-table
|
||||||
|
|
||||||
|
TUPLE: label offset ;
|
||||||
|
|
||||||
|
: <label> ( -- label ) label new ;
|
||||||
|
: define-label ( name -- ) <label> swap set ;
|
||||||
|
|
||||||
|
: resolve-label ( label/name -- )
|
||||||
|
dup label? [ get ] unless
|
||||||
|
compiled-offset >>offset drop ;
|
||||||
|
|
||||||
|
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
|
||||||
|
|
||||||
|
: label-fixup ( label class -- )
|
||||||
|
compiled-offset \ label-fixup boa label-table get push ;
|
||||||
|
|
||||||
|
: compute-target ( label-fixup -- offset )
|
||||||
|
label>> offset>> [ "Unresolved label" throw ] unless* ;
|
||||||
|
|
||||||
|
: compute-relative-label ( label-fixup -- label )
|
||||||
|
[ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
|
||||||
|
|
||||||
|
: compute-absolute-label ( label-fixup -- )
|
||||||
|
[ compute-target neg add-literal ]
|
||||||
|
[ [ class>> rt-here ] [ offset>> ] bi add-relocation-at ] bi ;
|
||||||
|
|
||||||
|
: compute-labels ( label-fixups -- labels' )
|
||||||
|
[ class>> rc-absolute? ] partition
|
||||||
|
[ [ compute-absolute-label ] each ]
|
||||||
|
[ [ compute-relative-label ] map concat ]
|
||||||
|
bi* ;
|
||||||
|
|
||||||
|
! Binary literals
|
||||||
|
SYMBOL: binary-literal-table
|
||||||
|
|
||||||
|
: add-binary-literal ( obj -- label )
|
||||||
|
<label> [ 2array binary-literal-table get push ] keep ;
|
||||||
|
|
||||||
|
: rel-binary-literal ( literal class -- )
|
||||||
|
[ add-binary-literal ] dip label-fixup ;
|
||||||
|
|
||||||
|
: emit-data ( obj label -- )
|
||||||
|
over length align-code
|
||||||
|
resolve-label
|
||||||
|
building get push-all ;
|
||||||
|
|
||||||
|
: emit-binary-literals ( -- )
|
||||||
|
binary-literal-table get [ emit-data ] assoc-each ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,90 @@
|
||||||
|
! Copyright (C) 2011 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors alien.accessors alien.strings
|
||||||
|
compiler.constants kernel make math math.bitwise memoize
|
||||||
|
namespaces sequences ;
|
||||||
|
IN: compiler.codegen.relocation
|
||||||
|
|
||||||
|
! Common code shared by optimizing and non-optimizing compilers.
|
||||||
|
! Should not have too many dependencies on the rest of the
|
||||||
|
! optimizing compiler.
|
||||||
|
|
||||||
|
! Code is compiled into the 'make' vector.
|
||||||
|
|
||||||
|
: compiled-offset ( -- n ) building get length ;
|
||||||
|
|
||||||
|
: alignment ( align -- n )
|
||||||
|
[ compiled-offset dup ] dip align swap - ;
|
||||||
|
|
||||||
|
: (align-code) ( n -- )
|
||||||
|
0 <repetition> % ;
|
||||||
|
|
||||||
|
: align-code ( n -- )
|
||||||
|
alignment (align-code) ;
|
||||||
|
|
||||||
|
! Parameter table
|
||||||
|
SYMBOL: parameter-table
|
||||||
|
|
||||||
|
: add-parameter ( obj -- ) parameter-table get push ;
|
||||||
|
|
||||||
|
! Literal table
|
||||||
|
SYMBOL: literal-table
|
||||||
|
|
||||||
|
: add-literal ( obj -- ) literal-table get push ;
|
||||||
|
|
||||||
|
! Relocation table
|
||||||
|
SYMBOL: relocation-table
|
||||||
|
|
||||||
|
: push-uint ( value vector -- )
|
||||||
|
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
|
||||||
|
swap set-alien-unsigned-4 ;
|
||||||
|
|
||||||
|
: add-relocation-at ( class type offset -- )
|
||||||
|
{ 0 28 24 } bitfield relocation-table get push-uint ;
|
||||||
|
|
||||||
|
: add-relocation ( class type -- )
|
||||||
|
compiled-offset add-relocation-at ;
|
||||||
|
|
||||||
|
! Caching common symbol names reduces image size a bit
|
||||||
|
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
|
||||||
|
|
||||||
|
: add-dlsym-parameters ( symbol dll -- )
|
||||||
|
[ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
|
||||||
|
|
||||||
|
: rel-dlsym ( name dll class -- )
|
||||||
|
[ add-dlsym-parameters ] dip rt-dlsym add-relocation ;
|
||||||
|
|
||||||
|
: rel-dlsym-toc ( name dll class -- )
|
||||||
|
[ add-dlsym-parameters ] dip rt-dlsym-toc add-relocation ;
|
||||||
|
|
||||||
|
: rel-word ( word class -- )
|
||||||
|
[ add-literal ] dip rt-entry-point add-relocation ;
|
||||||
|
|
||||||
|
: rel-word-pic ( word class -- )
|
||||||
|
[ add-literal ] dip rt-entry-point-pic add-relocation ;
|
||||||
|
|
||||||
|
: rel-word-pic-tail ( word class -- )
|
||||||
|
[ add-literal ] dip rt-entry-point-pic-tail add-relocation ;
|
||||||
|
|
||||||
|
: rel-literal ( literal class -- )
|
||||||
|
[ add-literal ] dip rt-literal add-relocation ;
|
||||||
|
|
||||||
|
: rel-this ( class -- )
|
||||||
|
rt-this add-relocation ;
|
||||||
|
|
||||||
|
: rel-here ( offset class -- )
|
||||||
|
[ add-literal ] dip rt-here add-relocation ;
|
||||||
|
|
||||||
|
: rel-vm ( offset class -- )
|
||||||
|
[ add-parameter ] dip rt-vm add-relocation ;
|
||||||
|
|
||||||
|
: rel-cards-offset ( class -- )
|
||||||
|
rt-cards-offset add-relocation ;
|
||||||
|
|
||||||
|
: rel-decks-offset ( class -- )
|
||||||
|
rt-decks-offset add-relocation ;
|
||||||
|
|
||||||
|
: init-relocation ( -- )
|
||||||
|
V{ } clone parameter-table set
|
||||||
|
V{ } clone literal-table set
|
||||||
|
BV{ } clone relocation-table set ;
|
||||||
|
|
@ -1,9 +1,10 @@
|
||||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
! Copyright (C) 2005, 2011 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: locals alien alien.c-types alien.libraries alien.syntax
|
USING: locals alien alien.c-types alien.libraries alien.syntax
|
||||||
arrays kernel fry math namespaces sequences system layouts io
|
arrays kernel fry math namespaces sequences system layouts io
|
||||||
vocabs.loader accessors init classes.struct combinators make
|
vocabs.loader accessors init classes.struct combinators make
|
||||||
words compiler.constants compiler.codegen.fixup
|
words compiler.constants compiler.codegen.gc-maps
|
||||||
|
compiler.codegen.labels compiler.codegen.relocation
|
||||||
compiler.cfg.instructions compiler.cfg.builder
|
compiler.cfg.instructions compiler.cfg.builder
|
||||||
compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
|
compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
|
||||||
compiler.cfg.stack-frame cpu.x86.assembler
|
compiler.cfg.stack-frame cpu.x86.assembler
|
||||||
|
|
|
||||||
|
|
@ -1,13 +1,14 @@
|
||||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
! Copyright (C) 2005, 2011 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays kernel math namespaces make sequences
|
USING: accessors arrays kernel math namespaces make sequences
|
||||||
system layouts alien alien.c-types alien.accessors alien.libraries
|
system layouts alien alien.c-types alien.accessors
|
||||||
slots splitting assocs combinators fry locals compiler.constants
|
alien.libraries slots splitting assocs combinators fry locals
|
||||||
classes.struct compiler.codegen compiler.codegen.fixup
|
compiler.constants classes.struct compiler.codegen
|
||||||
compiler.cfg.instructions compiler.cfg.builder
|
compiler.codegen.gc-maps compiler.codegen.labels
|
||||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
compiler.codegen.relocation compiler.cfg.instructions
|
||||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
|
compiler.cfg.builder compiler.cfg.intrinsics
|
||||||
cpu.architecture vm ;
|
compiler.cfg.stack-frame cpu.x86.assembler
|
||||||
|
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
|
||||||
FROM: layouts => cell cells ;
|
FROM: layouts => cell cells ;
|
||||||
IN: cpu.x86.64
|
IN: cpu.x86.64
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs sequences alien alien.c-types
|
USING: accessors assocs sequences alien alien.c-types
|
||||||
combinators compiler compiler.codegen.fixup compiler.units
|
combinators compiler compiler.codegen.labels compiler.units
|
||||||
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
|
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
|
||||||
init io kernel locals math math.order math.parser memoize
|
init io kernel locals math math.order math.parser memoize
|
||||||
namespaces system ;
|
namespaces system ;
|
||||||
|
|
|
||||||
|
|
@ -3,8 +3,9 @@
|
||||||
USING: alien.data arrays assocs combinators fry kernel locals
|
USING: alien.data arrays assocs combinators fry kernel locals
|
||||||
macros math math.vectors namespaces quotations sequences system
|
macros math math.vectors namespaces quotations sequences system
|
||||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||||
compiler.codegen.fixup cpu.architecture cpu.x86
|
compiler.codegen.labels compiler.codegen.relocation
|
||||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
|
cpu.architecture cpu.x86 cpu.x86.assembler
|
||||||
|
cpu.x86.assembler.operands cpu.x86.features ;
|
||||||
QUALIFIED-WITH: alien.c-types c
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: cpu.x86.sse
|
IN: cpu.x86.sse
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,9 @@ compiler.cfg.instructions
|
||||||
compiler.cfg.intrinsics
|
compiler.cfg.intrinsics
|
||||||
compiler.cfg.comparisons
|
compiler.cfg.comparisons
|
||||||
compiler.cfg.stack-frame
|
compiler.cfg.stack-frame
|
||||||
compiler.codegen.fixup ;
|
compiler.codegen.gc-maps
|
||||||
|
compiler.codegen.labels
|
||||||
|
compiler.codegen.relocation ;
|
||||||
QUALIFIED-WITH: alien.c-types c
|
QUALIFIED-WITH: alien.c-types c
|
||||||
FROM: layouts => cell ;
|
FROM: layouts => cell ;
|
||||||
FROM: math => float ;
|
FROM: math => float ;
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2010 Slava Pestov.
|
! Copyright (C) 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types alien.data combinators kernel locals system
|
USING: alien.c-types alien.data combinators kernel locals system
|
||||||
namespaces compiler.codegen.fixup compiler.constants
|
namespaces compiler.codegen.labels compiler.codegen.relocation
|
||||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
compiler.constants compiler.cfg.comparisons
|
||||||
cpu.architecture cpu.x86 cpu.x86.assembler
|
compiler.cfg.intrinsics cpu.architecture cpu.x86
|
||||||
cpu.x86.assembler.operands ;
|
cpu.x86.assembler cpu.x86.assembler.operands ;
|
||||||
IN: cpu.x86.x87
|
IN: cpu.x86.x87
|
||||||
|
|
||||||
! x87 unit is only used if SSE2 is not available.
|
! x87 unit is only used if SSE2 is not available.
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue