Various improvements aimed at getting local optimization regressions fixed:
- Rename _gc to ##gc - Absolute labels are now supported - Generate _dispatch-labeldb4
parent
2c8223fdaf
commit
fc152ef210
|
@ -92,9 +92,12 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
|||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
M: ##dispatch generate-insn
|
||||
M: _dispatch generate-insn
|
||||
[ src>> register ] [ temp>> register ] bi %dispatch ;
|
||||
|
||||
M: _dispatch-label generate-insn
|
||||
label>> lookup-label %dispatch-label ;
|
||||
|
||||
: >slot< ( insn -- dst obj slot tag )
|
||||
{
|
||||
[ dst>> register ]
|
||||
|
@ -234,7 +237,7 @@ M: ##write-barrier generate-insn
|
|||
[ table>> register ]
|
||||
tri %write-barrier ;
|
||||
|
||||
M: _gc generate-insn drop %gc ;
|
||||
M: ##gc generate-insn drop %gc ;
|
||||
|
||||
M: ##loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
|
|
|
@ -16,30 +16,33 @@ SYMBOL: label-table
|
|||
|
||||
M: label fixup* compiled-offset >>offset drop ;
|
||||
|
||||
TUPLE: label-fixup label class ;
|
||||
: offset-for-class ( class -- n )
|
||||
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
|
||||
|
||||
TUPLE: label-fixup { label label } { class integer } ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
[ class>> ] [ label>> ] bi compiled-offset 4 - swap
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup class type ;
|
||||
|
||||
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
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>> ]
|
||||
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
|
||||
{ 0 24 28 } bitfield
|
||||
relocation-table get push-4 ;
|
||||
[ type>> ] [ class>> dup offset-for-class ] bi
|
||||
add-relocation-entry ;
|
||||
|
||||
M: integer fixup* , ;
|
||||
|
||||
|
|
|
@ -52,6 +52,7 @@ HOOK: %jump-label cpu ( label -- )
|
|||
HOOK: %return cpu ( -- )
|
||||
|
||||
HOOK: %dispatch cpu ( src temp -- )
|
||||
HOOK: %dispatch-label cpu ( src temp -- )
|
||||
|
||||
HOOK: %slot cpu ( dst obj slot tag temp -- )
|
||||
HOOK: %slot-imm cpu ( dst obj slot tag -- )
|
||||
|
|
|
@ -79,6 +79,9 @@ M: x86 %return ( -- ) 0 RET ;
|
|||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86 %dispatch-label ( label -- )
|
||||
0 cell, rc-absolute-cell label-fixup ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- op )
|
||||
temp slot obj [+] LEA
|
||||
temp tag neg [+] ; inline
|
||||
|
|
|
@ -159,7 +159,7 @@ 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 + (short)untag_fixnum(ARG);
|
||||
return offset + untag_fixnum(ARG);
|
||||
case RT_THIS:
|
||||
return (cell)(compiled + 1);
|
||||
case RT_STACK_CHAIN:
|
||||
|
|
Loading…
Reference in New Issue