diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 11b4e153f6..223fc8edff 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 ; diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index d0c874feb0..bd1364dde1 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -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* , ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 98d0c5326b..e0e4343a60 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 8ab247f5e5..24832ac227 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -79,6 +79,9 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; +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 diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 2ce69ebfde..050e154c28 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -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(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: