steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Reworking relocation code

cvs
Slava Pestov 2005-12-04 21:20:17 +00:00
parent 57e990c35a
commit 70f44ce9e4
5 changed files with 109 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
library/bootstrap/boot-stage1.factor
View File

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

2
library/compiler/generator.factor
View File

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

35
library/compiler/relocate.factor
View File

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

6
library/compiler/x86/assembler.factor
View File

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

191
library/compiler/xt.factor
View File

@ -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 ;
: <fixup-3> ( resolver at -- )
#! Only for PowerPC branch instructions.
BIN: 11111111111111111111111100 <fixup-bitfield> ;
: <fixup-2> ( resolver at -- )
#! Only for PowerPC conditional branch instructions.
BIN: 1111111111111100 <fixup-bitfield> ;
: 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 <relative>
compiled-offset 4 - <fixup-4> deferred-xt ;
: absolute-cell ( word -- )
dup 0 0 rel-word
<absolute> compiled-offset cell - <fixup-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 -- ) <relative> 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 <absolute> 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 <relative> r> set-delegate ] keep
[ just-compiled swap set-relative-to ] keep ;
: relative-24 ( word -- )
BIN: 11111111111111111111111100 <relative-bitfld>
deferred-xt ;
: relative-14 ( word -- )
BIN: 1111111111111100 <relative-bitfld>
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 <absolute> 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 -- )
<absolute-16/16> 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