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
|
||||
compiler.constants words ;
|
||||
USING: compiler.codegen compiler.codegen.labels
|
||||
compiler.codegen.relocation tools.test cpu.architecture math
|
||||
kernel make compiler.constants words ;
|
||||
IN: compiler.codegen.tests
|
||||
|
||||
[ ] [ [ ] 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.
|
||||
USING: namespaces make math math.order math.parser sequences
|
||||
accessors kernel layouts assocs words summary arrays combinators
|
||||
classes.algebra sets continuations.private fry cpu.architecture
|
||||
classes classes.struct locals slots parser generic.parser
|
||||
strings quotations hashtables
|
||||
USING: byte-arrays namespaces make math math.order math.parser
|
||||
sequences accessors kernel layouts assocs words summary arrays
|
||||
combinators combinators.smart sets continuations.private fry
|
||||
cpu.architecture classes classes.struct locals slots parser
|
||||
generic.parser strings quotations hashtables
|
||||
compiler.constants
|
||||
compiler.cfg
|
||||
compiler.cfg.linearization
|
||||
|
|
@ -13,7 +13,9 @@ compiler.cfg.comparisons
|
|||
compiler.cfg.stack-frame
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.builder
|
||||
compiler.codegen.fixup
|
||||
compiler.codegen.gc-maps
|
||||
compiler.codegen.labels
|
||||
compiler.codegen.relocation
|
||||
compiler.utilities ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.codegen
|
||||
|
|
@ -81,6 +83,31 @@ M: ##dispatch generate-insn
|
|||
] each
|
||||
] 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 )
|
||||
[
|
||||
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
|
||||
sequences alien.c-types specialized-arrays boxes
|
||||
compiler.cfg.instructions system cpu.architecture ;
|
||||
SPECIALIZED-ARRAY: uint
|
||||
IN: compiler.codegen.fixup.tests
|
||||
IN: compiler.codegen.gc-maps.tests
|
||||
|
||||
STRUCT: gc-info
|
||||
{ scrub-d-count uint }
|
||||
|
|
@ -20,7 +20,7 @@ M: fake-cpu gc-root-offset ;
|
|||
|
||||
[ ] [
|
||||
[
|
||||
init-fixup
|
||||
init-gc-maps
|
||||
|
||||
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
|
||||
|
||||
emit-gc-info
|
||||
emit-gc-maps
|
||||
] B{ } make
|
||||
"result" set
|
||||
] 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.
|
||||
USING: locals alien alien.c-types alien.libraries alien.syntax
|
||||
arrays kernel fry math namespaces sequences system layouts io
|
||||
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.builder.alien.boxing compiler.cfg.intrinsics
|
||||
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.
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.libraries
|
||||
slots splitting assocs combinators fry locals compiler.constants
|
||||
classes.struct compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
|
||||
cpu.architecture vm ;
|
||||
system layouts alien alien.c-types alien.accessors
|
||||
alien.libraries slots splitting assocs combinators fry locals
|
||||
compiler.constants classes.struct compiler.codegen
|
||||
compiler.codegen.gc-maps compiler.codegen.labels
|
||||
compiler.codegen.relocation compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame cpu.x86.assembler
|
||||
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
|
||||
FROM: layouts => cell cells ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
init io kernel locals math math.order math.parser memoize
|
||||
namespaces system ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
USING: alien.data arrays assocs combinators fry kernel locals
|
||||
macros math math.vectors namespaces quotations sequences system
|
||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||
compiler.codegen.fixup cpu.architecture cpu.x86
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features ;
|
||||
compiler.codegen.labels compiler.codegen.relocation
|
||||
cpu.architecture cpu.x86 cpu.x86.assembler
|
||||
cpu.x86.assembler.operands cpu.x86.features ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: cpu.x86.sse
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,9 @@ compiler.cfg.instructions
|
|||
compiler.cfg.intrinsics
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.codegen.fixup ;
|
||||
compiler.codegen.gc-maps
|
||||
compiler.codegen.labels
|
||||
compiler.codegen.relocation ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
FROM: layouts => cell ;
|
||||
FROM: math => float ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.data combinators kernel locals system
|
||||
namespaces compiler.codegen.fixup compiler.constants
|
||||
compiler.cfg.comparisons compiler.cfg.intrinsics
|
||||
cpu.architecture cpu.x86 cpu.x86.assembler
|
||||
cpu.x86.assembler.operands ;
|
||||
namespaces compiler.codegen.labels compiler.codegen.relocation
|
||||
compiler.constants compiler.cfg.comparisons
|
||||
compiler.cfg.intrinsics cpu.architecture cpu.x86
|
||||
cpu.x86.assembler cpu.x86.assembler.operands ;
|
||||
IN: cpu.x86.x87
|
||||
|
||||
! x87 unit is only used if SSE2 is not available.
|
||||
|
|
|
|||
Loading…
Reference in New Issue