Redo compiler.codegen.fixup and get %dispatch to work
parent
fc152ef210
commit
b389dcf441
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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> % ;
|
||||
|
|
|
@ -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:
|
||||
|
|
Loading…
Reference in New Issue