Redo compiler.codegen.fixup and get %dispatch to work

db4
Slava Pestov 2009-06-01 02:32:36 -05:00
parent fc152ef210
commit b389dcf441
6 changed files with 81 additions and 65 deletions

View File

@ -0,0 +1,14 @@
IN: compiler.codegen.tests
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ;
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

View File

@ -26,14 +26,6 @@ SYMBOL: registers
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ;
SYMBOL: calls
@ -51,17 +43,22 @@ SYMBOL: labels
: init-generator ( word -- )
H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate-insns ( asm -- code )
[
[ word>> init-generator ]
[
instructions>>
[ [ regs>> registers set ] [ generate-insn ] bi ] each
] bi
] with-fixup ;
: generate ( mr -- asm )
[
[ label>> ]
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
[ label>> ] [ generate-insns ] bi calls get
asm boa
] with-scope ;
@ -487,7 +484,7 @@ M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
id>> lookup-label , ;
id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;

View File

@ -4,51 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ;
accessors growable compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
! 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 ;
SYMBOL: relocation-table
SYMBOL: label-table
M: label fixup* compiled-offset >>offset drop ;
: resolve-label ( label/name -- )
dup label? [ get ] unless
compiled-offset >>offset drop ;
: offset-for-class ( class -- n )
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
TUPLE: label-fixup { label label } { class integer } ;
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
: label-fixup ( label class -- )
dup offset-for-class \ label-fixup boa label-table get push ;
! Relocation table
SYMBOL: relocation-table
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
: add-relocation-entry ( type class offset -- )
{ 0 24 28 } bitfield relocation-table get push-4 ;
{ 0 24 28 } bitfield relocation-table get push-4 ;
M: label-fixup fixup*
[ class>> dup offset-for-class ] [ label>> ] bi
[ drop [ rt-here ] 2dip add-relocation-entry ]
[ 3array label-table get push ]
3bi ;
TUPLE: rel-fixup { class integer } { type integer } ;
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
M: rel-fixup fixup*
[ type>> ] [ class>> dup offset-for-class ] bi
add-relocation-entry ;
M: integer fixup* , ;
SYMBOL: literal-table
: add-literal ( obj -- ) literal-table get push ;
: rel-fixup ( class type -- )
swap dup offset-for-class add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
@ -77,22 +74,34 @@ SYMBOL: literal-table
: rel-here ( offset class -- )
[ add-literal ] dip rt-here rel-fixup ;
! And the rest
: resolve-offset ( label-fixup -- offset )
label>> offset>> [ "Unresolved label" throw ] unless* ;
: resolve-absolute-label ( label-fixup -- )
dup resolve-offset neg add-literal
[ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
: resolve-relative-label ( label-fixup -- )
[ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
: resolve-labels ( label-fixups -- labels' )
[ class>> rc-absolute? ] partition
[ [ resolve-absolute-label ] each ]
[ [ resolve-relative-label ] map concat ]
bi* ;
: init-fixup ( -- )
BV{ } clone relocation-table set
V{ } clone label-table set ;
V{ } clone literal-table set
V{ } clone label-table set
BV{ } clone relocation-table set ;
: resolve-labels ( labels -- labels' )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( fixup-directives -- code )
: with-fixup ( quot -- code )
[
init-fixup
[ fixup* ] each
call
label-table [ resolve-labels ] change
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] B{ } make 4array ;
label-table get
] B{ } make 4array ; inline

View File

@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
@ -52,7 +45,7 @@ HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( src temp -- )
HOOK: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )

View File

@ -74,7 +74,7 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )
[ building get [ integer? ] count dup ] dip align swap - ;
[ building get length dup ] dip align swap - ;
: align-code ( n -- )
0 <repetition> % ;

View File

@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE:
return offset + untag_fixnum(ARG);
{
fixnum arg = untag_fixnum(ARG);
return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
}
case RT_THIS:
return (cell)(compiled + 1);
case RT_STACK_CHAIN: