Various improvements aimed at getting local optimization regressions fixed:

- Rename _gc to ##gc
- Absolute labels are now supported
- Generate _dispatch-label
db4
Slava Pestov 2009-05-31 23:28:08 -05:00
parent 2c8223fdaf
commit fc152ef210
5 changed files with 29 additions and 19 deletions

View File

@ -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 ;

View File

@ -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* , ;

View File

@ -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 -- )

View File

@ -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

View File

@ -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: