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