From 70f44ce9e4636f24621faaca436b6f11e2710ced Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Dec 2005 21:20:17 +0000 Subject: [PATCH] Reworking relocation code --- library/bootstrap/boot-stage1.factor | 1 - library/compiler/generator.factor | 2 +- library/compiler/relocate.factor | 35 ----- library/compiler/x86/assembler.factor | 6 +- library/compiler/xt.factor | 191 ++++++++++++++------------ 5 files changed, 109 insertions(+), 126 deletions(-) delete mode 100644 library/compiler/relocate.factor diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 2030502172..42c404c22f 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -126,7 +126,6 @@ vectors words ; "/library/inference/print-dataflow.factor" "/library/compiler/assembler.factor" - "/library/compiler/relocate.factor" "/library/compiler/xt.factor" "/library/compiler/vops.factor" "/library/compiler/linearizer.factor" diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 6d7d20b553..86f640132f 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -57,7 +57,7 @@ M: %label generate-node ( vop -- ) M: %end-dispatch generate-node ( vop -- ) drop ; -: compile-target ( word -- ) 0 assemble-cell absolute ; +: compile-target ( word -- ) 0 assemble-cell absolute-cell ; M: %target-label generate-node vop-label compile-target ; diff --git a/library/compiler/relocate.factor b/library/compiler/relocate.factor deleted file mode 100644 index 10814a36c3..0000000000 --- a/library/compiler/relocate.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: compiler -USING: assembler compiler-backend kernel kernel-internals lists -math namespaces sequences words ; - -! To support saving compiled code to disk, generator words -! append relocation instructions to this vector. -SYMBOL: relocation-table - -: rel, ( n -- ) relocation-table get push ; - -: relocating compiled-offset cell - rel, ; - -: rel-type, ( rel/abs 16/16 type -- ) - swap 8 shift bitor swap 16 shift bitor rel, ; - -: rel-primitive ( word relative 16/16 -- ) - 0 rel-type, relocating word-primitive rel, ; - -: rel-dlsym ( name dll rel/abs 16/16 -- ) - 1 rel-type, relocating cons add-literal rel, ; - -: rel-address ( rel/abs 16/16 -- ) - #! Relocate address just compiled. - over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ; - -: rel-word ( word rel/abs 16/16 -- ) - pick primitive? [ rel-primitive ] [ rel-address drop ] if ; - -: rel-userenv ( n 16/16 -- ) - 0 swap 3 rel-type, relocating rel, ; - -: rel-cards ( 16/16 -- ) - 0 swap 4 rel-type, compiled-offset cell 2 * - rel, 0 rel, ; diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index e4edc5b16d..6d3cdfccf5 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -190,18 +190,18 @@ M: operand MOV HEX: 89 2-operand ; GENERIC: JMP ( op -- ) M: integer JMP HEX: e9 assemble-1 from assemble-4 ; M: operand JMP BIN: 100 t HEX: ff 1-operand ; -M: word JMP 0 JMP relative ; +M: word JMP 0 JMP relative-4 ; GENERIC: CALL ( op -- ) M: integer CALL HEX: e8 assemble-1 from assemble-4 ; M: operand CALL BIN: 010 t HEX: ff 1-operand ; -M: word CALL 0 CALL relative ; +M: word CALL 0 CALL relative-4 ; GENERIC: JUMPcc ( opcode addr -- ) M: integer JUMPcc ( opcode addr -- ) HEX: 0f assemble-1 swap assemble-1 from assemble-4 ; M: word JUMPcc ( opcode addr -- ) - >r 0 JUMPcc r> relative ; + >r 0 JUMPcc r> relative-4 ; : JO HEX: 80 swap JUMPcc ; : JNO HEX: 81 swap JUMPcc ; diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index 97ee8c4fe6..19d99cbfae 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -1,18 +1,113 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler -USING: assembler errors generic hashtables kernel lists math -namespaces prettyprint sequences strings vectors words ; +USING: assembler errors generic hashtables kernel +kernel-internals lists math namespaces prettyprint sequences +strings vectors words ; + +! To support saving compiled code to disk, generator words +! append relocation instructions to this vector. +SYMBOL: relocation-table + +: rel, ( n -- ) relocation-table get push ; + +: relocating compiled-offset cell - rel, ; + +: rel-type, ( rel/abs 16/16 type -- ) + swap 8 shift bitor swap 16 shift bitor rel, ; + +: rel-primitive ( word relative 16/16 -- ) + 0 rel-type, relocating word-primitive rel, ; + +: rel-dlsym ( name dll rel/abs 16/16 -- ) + 1 rel-type, relocating cons add-literal rel, ; + +: rel-address ( rel/abs 16/16 -- ) + #! Relocate address just compiled. + over 1 = [ 2drop ] [ 2 rel-type, relocating 0 rel, ] if ; + +: rel-word ( word rel/abs 16/16 -- ) + pick primitive? [ rel-primitive ] [ rel-address drop ] if ; + +: rel-userenv ( n 16/16 -- ) + 0 swap 3 rel-type, relocating rel, ; + +: rel-cards ( 16/16 -- ) + 0 swap 4 rel-type, compiled-offset cell 2 * - rel, 0 rel, ; + +! This is for fixing up forward references +GENERIC: resolve ( fixup -- addr ) + +TUPLE: absolute word ; + +M: absolute resolve absolute-word compiled-xt ; + +TUPLE: relative word to ; + +M: relative resolve + [ relative-word compiled-xt ] keep relative-to - ; + +GENERIC: fixup ( addr fixup -- ) + +TUPLE: fixup-cell at ; + +C: fixup-cell ( resolver at -- fixup ) + [ set-fixup-cell-at ] keep [ set-delegate ] keep ; + +M: fixup-cell fixup ( addr fixup -- ) + fixup-cell-at set-compiled-cell ; + +TUPLE: fixup-4 at ; + +C: fixup-4 ( resolver at -- fixup ) + [ set-fixup-4-at ] keep [ set-delegate ] keep ; + +M: fixup-4 fixup ( addr fixup -- ) + fixup-4-at set-compiled-4 ; + +TUPLE: fixup-bitfield at mask ; + +C: fixup-bitfield ( resolver at mask -- fixup ) + [ set-fixup-bitfield-mask ] keep + [ set-fixup-bitfield-at ] keep + [ set-delegate ] keep ; + +: ( resolver at -- ) + #! Only for PowerPC branch instructions. + BIN: 11111111111111111111111100 ; + +: ( resolver at -- ) + #! Only for PowerPC conditional branch instructions. + BIN: 1111111111111100 ; + +: or-compiled ( n off -- ) + [ compiled-cell bitor ] keep set-compiled-cell ; + +M: fixup-bitfield fixup ( addr fixup -- ) + [ fixup-bitfield-mask bitand ] keep + fixup-bitfield-at or-compiled ; + +TUPLE: fixup-2/2 at ; + +C: fixup-2/2 ( resolver at -- fixup ) + [ set-fixup-2/2-at ] keep [ set-delegate ] keep ; + +M: fixup-2/2 fixup ( addr fixup -- ) + fixup-2/2-at >r w>h/h r> tuck 4 - or-compiled or-compiled ; + +: relative-4 ( word -- ) + dup 1 0 rel-word + compiled-offset + compiled-offset 4 - deferred-xt ; + +: absolute-cell ( word -- ) + dup 0 0 rel-word + compiled-offset cell - deferred-xt ; ! We use a hashtable "compiled-xts" that maps words to ! xt's that are currently being compiled. The commit-xt's word ! sets the xt of each word in the hashtable to the value in the ! hastable. -! -! This has the advantage that we can compile a word before the -! words it depends on and perform a fixup later; among other -! things this enables mutually recursive words. - SYMBOL: compiled-xts : save-xt ( word -- ) @@ -30,89 +125,13 @@ SYMBOL: compiled-xts ! When a word is encountered that has not been previously ! compiled, it is pushed onto this vector. Compilation stops ! when the vector is empty. - SYMBOL: compile-words -! deferred-xts is a list of objects responding to the fixup +! deferred-xts is a vector of objects responding to the fixup ! generic. SYMBOL: deferred-xts -! Some machinery to allow forward references -GENERIC: fixup ( object -- ) - -TUPLE: relative word where to ; - -: just-compiled compiled-offset 4 - ; - -C: relative ( word -- ) - over 1 0 rel-word - [ set-relative-word ] keep - [ just-compiled swap set-relative-where ] keep - [ compiled-offset swap set-relative-to ] keep ; - -: deferred-xt deferred-xts [ cons ] change ; - -: relative ( word -- ) deferred-xt ; - -: relative-fixup ( relative -- addr ) - dup relative-word compiled-xt swap relative-to - ; - -M: relative fixup ( relative -- ) - dup relative-fixup swap relative-where set-compiled-cell ; - -TUPLE: absolute word where ; - -C: absolute ( word -- ) - [ set-absolute-word ] keep - [ just-compiled swap set-absolute-where ] keep ; - -: absolute ( word -- ) - dup 0 0 rel-word deferred-xt ; - -: >absolute dup absolute-word compiled-xt swap absolute-where ; - -M: absolute fixup ( absolute -- ) - >absolute set-compiled-cell ; - -! Fixups where the address is inside a bitfield in the -! instruction. -TUPLE: relative-bitfld mask ; - -C: relative-bitfld ( word mask -- ) - [ set-relative-bitfld-mask ] keep - [ >r r> set-delegate ] keep - [ just-compiled swap set-relative-to ] keep ; - -: relative-24 ( word -- ) - BIN: 11111111111111111111111100 - deferred-xt ; - -: relative-14 ( word -- ) - BIN: 1111111111111100 - deferred-xt ; - -: or-compiled ( n off -- ) - [ compiled-cell bitor ] keep set-compiled-cell ; - -M: relative-bitfld fixup - dup relative-fixup over relative-bitfld-mask bitand - swap relative-where - or-compiled ; - -! Fixup where the address is split between two PowerPC D-form -! instructions (low 16 bits of each instruction is the literal). -TUPLE: absolute-16/16 ; - -C: absolute-16/16 ( word -- ) - [ >r r> set-delegate ] keep ; - -: fixup-16/16 ( xt where -- ) - >r w>h/h r> tuck 4 - or-compiled or-compiled ; - -M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ; - -: absolute-16/16 ( word -- ) - deferred-xt 0 1 rel-address ; +: deferred-xt deferred-xts get push ; : compiling? ( word -- ? ) #! A word that is compiling or already compiled will not be @@ -132,7 +151,7 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ; : with-compiler ( quot -- ) [ - deferred-xts off + V{ } deferred-xts set H{ } clone compiled-xts set V{ } clone compile-words set call