Big redesign of the compiler/runtime interface
slava
parent
be9916c903
commit
251f12448f
|
|
@ -17,7 +17,6 @@
|
|||
- instead of decompiling words, add them to a 'recompile' set; compiler
|
||||
treats words in the recompile set as if they were not compiled
|
||||
- see if alien calls can be made faster
|
||||
- faster sequence= for UI
|
||||
- remove literal table
|
||||
|
||||
========================================================================
|
||||
|
|
|
|||
|
|
@ -142,7 +142,6 @@ sequences vectors words ;
|
|||
"/library/compiler/optimizer/print-dataflow.factor"
|
||||
|
||||
"/library/compiler/generator/architecture.factor"
|
||||
"/library/compiler/generator/assembler.factor"
|
||||
"/library/compiler/generator/templates.factor"
|
||||
"/library/compiler/generator/xt.factor"
|
||||
"/library/compiler/generator/generator.factor"
|
||||
|
|
@ -251,7 +250,6 @@ sequences vectors words ;
|
|||
"/library/compiler/alien/malloc.facts"
|
||||
"/library/compiler/alien/structs.facts"
|
||||
"/library/compiler/alien/syntax.facts"
|
||||
"/library/compiler/generator/assembler.facts"
|
||||
"/library/compiler/inference/inference.facts"
|
||||
"/library/compiler/compiler.facts"
|
||||
"/library/generic/early-generic.facts"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: image
|
|||
( Constants )
|
||||
|
||||
: image-magic HEX: 0f0e0d0c ; inline
|
||||
: image-version 0 ; inline
|
||||
: image-version 2 ; inline
|
||||
|
||||
: char bootstrap-cell 2 /i ; inline
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ IN: image
|
|||
: tuple-type 17 ; inline
|
||||
: byte-array-type 18 ; inline
|
||||
|
||||
: base 1024 ; inline
|
||||
: data-base 1024 ; inline
|
||||
|
||||
: boot-quot-offset 3 ; inline
|
||||
: global-offset 4 ; inline
|
||||
|
|
@ -44,8 +44,10 @@ IN: image
|
|||
: 0-offset 6 ; inline
|
||||
: 1-offset 7 ; inline
|
||||
: -1-offset 8 ; inline
|
||||
: heap-size-offset 9 ; inline
|
||||
: header-size 10 ; inline
|
||||
: data-heap-size-offset 9 ; inline
|
||||
: code-heap-size-offset 10 ; inline
|
||||
|
||||
: header-size 12 ; inline
|
||||
|
||||
! The image being constructed; a vector of word-size integers
|
||||
SYMBOL: image
|
||||
|
|
@ -61,9 +63,6 @@ SYMBOL: architecture
|
|||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
: d>w/w ( d -- w w )
|
||||
dup HEX: ffffffff bitand swap -32 shift HEX: ffffffff bitand ;
|
||||
|
||||
: emit-64 ( cell -- )
|
||||
bootstrap-cell 8 = [
|
||||
emit
|
||||
|
|
@ -76,7 +75,7 @@ SYMBOL: architecture
|
|||
: fixup ( value offset -- ) image get set-nth ;
|
||||
|
||||
: here ( -- size )
|
||||
image get length header-size - bootstrap-cells base + ;
|
||||
image get length header-size - bootstrap-cells data-base + ;
|
||||
|
||||
: here-as ( tag -- pointer ) here swap bitor ;
|
||||
|
||||
|
|
@ -93,14 +92,16 @@ SYMBOL: architecture
|
|||
: header ( -- )
|
||||
image-magic emit
|
||||
image-version emit
|
||||
( relocation base at end of header ) base emit
|
||||
( relocation base at end of header ) data-base emit
|
||||
( bootstrap quotation set later ) 0 emit
|
||||
( global namespace set later ) 0 emit
|
||||
( pointer to t object ) 0 emit
|
||||
( pointer to bignum 0 ) 0 emit
|
||||
( pointer to bignum 1 ) 0 emit
|
||||
( pointer to bignum -1 ) 0 emit
|
||||
( size of heap set later ) 0 emit ;
|
||||
( size of data heap set later ) 0 emit
|
||||
( size of code heap is 0 ) 0 emit
|
||||
( reloc base of code heap is 0 ) 0 emit ;
|
||||
|
||||
GENERIC: ' ( obj -- ptr )
|
||||
#! Write an object to the image.
|
||||
|
|
@ -309,7 +310,7 @@ M: hashtable ' ( hashtable -- pointer )
|
|||
boot,
|
||||
"Performing some word fixups..." print flush
|
||||
fixup-words
|
||||
heap-size heap-size-offset fixup
|
||||
heap-size data-heap-size-offset fixup
|
||||
"Image length: " write image get length .
|
||||
"Object cache size: " write objects get hash-size .
|
||||
\ word global remove-hash ;
|
||||
|
|
|
|||
|
|
@ -149,10 +149,7 @@ call
|
|||
{ "tag" "kernel-internals" }
|
||||
{ "cwd" "io" }
|
||||
{ "cd" "io" }
|
||||
{ "compiled-offset" "assembler" }
|
||||
{ "set-compiled-offset" "assembler" }
|
||||
{ "add-literal" "assembler" }
|
||||
{ "address" "memory" }
|
||||
{ "add-compiled-block" "assembler" }
|
||||
{ "dlopen" "alien" }
|
||||
{ "dlsym" "alien" }
|
||||
{ "dlclose" "alien" }
|
||||
|
|
@ -206,7 +203,7 @@ call
|
|||
{ "end-scan" "memory" }
|
||||
{ "size" "memory" }
|
||||
{ "die" "kernel" }
|
||||
{ "flush-icache" "assembler" }
|
||||
{ "finalize-compile" "assembler" }
|
||||
{ "fopen" "io-internals" }
|
||||
{ "fgetc" "io-internals" }
|
||||
{ "fwrite" "io-internals" }
|
||||
|
|
|
|||
|
|
@ -40,3 +40,8 @@ HELP: compile-1 "( quot -- )"
|
|||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Compiles and runs a quotation." }
|
||||
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
|
||||
|
||||
IN: assembler
|
||||
|
||||
HELP: finalize-compile "( -- )"
|
||||
{ $description "Flushes the CPUs instruction cache on PowerPC, and does nothing on other architectures. PowerPC CPUs do not automatically invalidate the cache when memory contents change, so the compiler must do this explicitly." } ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,9 @@ IN: compiler
|
|||
USING: arrays generic kernel kernel-internals math memory
|
||||
namespaces sequences ;
|
||||
|
||||
! Does the assembler emit bytes or cells?
|
||||
DEFER: code-format ( -- byte# )
|
||||
|
||||
! A scratch register for computations
|
||||
TUPLE: vreg n ;
|
||||
|
||||
|
|
@ -130,4 +133,4 @@ M: float-regs inc-reg-class
|
|||
GENERIC: v>operand
|
||||
M: integer v>operand tag-bits shift ;
|
||||
M: vreg v>operand dup vreg-n swap vregs nth ;
|
||||
M: f v>operand address ;
|
||||
M: f v>operand drop object-tag ;
|
||||
|
|
|
|||
|
|
@ -1,36 +0,0 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: assembler
|
||||
USING: alien generic hashtables kernel kernel-internals
|
||||
math memory namespaces ;
|
||||
|
||||
: compiled-base 18 getenv ; inline
|
||||
|
||||
: compiled-header HEX: 01c3babe ; inline
|
||||
|
||||
: set-compiled-1 ( n a -- ) f swap set-alien-signed-1 ; inline
|
||||
: set-compiled-4 ( n a -- ) f swap set-alien-signed-4 ; inline
|
||||
: compiled-cell ( a -- n ) f swap alien-signed-cell ; inline
|
||||
: set-compiled-cell ( n a -- ) f swap set-alien-signed-cell ; inline
|
||||
|
||||
: compile-aligned ( n -- )
|
||||
compiled-offset 8 align set-compiled-offset ; inline
|
||||
|
||||
: assemble-1 ( n -- )
|
||||
compiled-offset set-compiled-1
|
||||
compiled-offset 1+ set-compiled-offset ; inline
|
||||
|
||||
: assemble-4 ( n -- )
|
||||
compiled-offset set-compiled-4
|
||||
compiled-offset 4 + set-compiled-offset ; inline
|
||||
|
||||
: assemble-cell ( n -- )
|
||||
compiled-offset set-compiled-cell
|
||||
compiled-offset cell + set-compiled-offset ; inline
|
||||
|
||||
: begin-assembly ( -- code-len-fixup reloc-len-fixup )
|
||||
compiled-header assemble-cell
|
||||
compiled-offset 0 assemble-cell
|
||||
compiled-offset 0 assemble-cell ;
|
||||
|
||||
: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
IN: assembler
|
||||
USING: help ;
|
||||
|
||||
HELP: compiled-offset "( -- n )"
|
||||
{ $values { "n" "an address" } }
|
||||
{ $description "Outputs the pointer to the top of the code heap where new code can be compiled." } ;
|
||||
|
||||
HELP: set-compiled-offset "( n -- )"
|
||||
{ $values { "n" "an address" } }
|
||||
{ $description "Sets the pointer to the top of the code heap where new code can be compiled." } ;
|
||||
|
||||
HELP: add-literal "( obj -- n )"
|
||||
{ $values { "obj" "an object" } { "n" "an address" } }
|
||||
{ $description "Adds a pointer to the object to the compiled literal area and outputs a pointer to a pointer to the object." } ;
|
||||
|
||||
HELP: flush-icache "( -- )"
|
||||
{ $description "Flushes the CPUs instruction cache on PowerPC, and does nothing on other architectures. PowerPC CPUs do not automatically invalidate the cache when memory contents change, so the compiler must do this explicitly." } ;
|
||||
|
|
@ -37,38 +37,22 @@ UNION: #terminal
|
|||
dup #terminal-call? swap node-successor #terminal? or
|
||||
] all? ;
|
||||
|
||||
: generate-code ( word node quot -- length | quot: node -- )
|
||||
compiled-offset >r
|
||||
compile-aligned
|
||||
rot save-xt
|
||||
over stack-reserve %prologue
|
||||
call
|
||||
compile-aligned
|
||||
compiled-offset r> - ;
|
||||
: generate-code ( node quot -- | quot: node -- )
|
||||
over stack-reserve %prologue call ; inline
|
||||
|
||||
: generate-reloc ( -- length )
|
||||
relocation-table get
|
||||
dup [ assemble-cell ] each
|
||||
length cells ;
|
||||
|
||||
SYMBOL: previous-offset
|
||||
|
||||
: begin-generating ( -- code-len-fixup reloc-len-fixup )
|
||||
compiled-offset previous-offset set
|
||||
: init-generator ( -- )
|
||||
V{ } clone relocation-table set
|
||||
init-templates begin-assembly swap ;
|
||||
V{ } clone literal-table set ;
|
||||
|
||||
: generate-1 ( word node quot -- | quot: node -- )
|
||||
#! If generation fails, reset compiled offset.
|
||||
[
|
||||
begin-generating >r >r
|
||||
init-generator
|
||||
init-templates
|
||||
generate-code
|
||||
generate-reloc
|
||||
r> set-compiled-cell
|
||||
r> set-compiled-cell
|
||||
] [
|
||||
previous-offset get set-compiled-offset rethrow
|
||||
] recover ;
|
||||
relocation-table get
|
||||
literal-table get
|
||||
] V{ } make
|
||||
code-format 2swap add-compiled-block swap save-xt ;
|
||||
|
||||
SYMBOL: generate-queue
|
||||
|
||||
|
|
@ -170,7 +154,7 @@ M: #call-label generate-node ( node -- next )
|
|||
node-param generate-call ;
|
||||
|
||||
! #dispatch
|
||||
: target-label ( label -- ) 0 assemble-cell absolute-cell ;
|
||||
: target-label ( label -- ) 0 , rel-absolute-cell rel-word ;
|
||||
|
||||
: dispatch-head ( node -- label/node )
|
||||
#! Output the jump table insn and return a list of
|
||||
|
|
|
|||
|
|
@ -18,152 +18,58 @@ sequences strings vectors words ;
|
|||
! hastable.
|
||||
SYMBOL: compiled-xts
|
||||
|
||||
: save-xt ( word -- )
|
||||
compiled-offset swap compiled-xts get set-hash ;
|
||||
: save-xt ( xt word -- ) compiled-xts get set-hash ;
|
||||
|
||||
: commit-xts ( -- )
|
||||
#! We must flush the instruction cache on PowerPC.
|
||||
flush-icache
|
||||
compiled-xts get [ swap set-word-xt ] hash-each ;
|
||||
|
||||
: compiled-xt ( word -- xt )
|
||||
dup compiled-xts get hash [ ] [ word-xt ] ?if ;
|
||||
|
||||
! deferred-xts is a vector of objects responding to the fixup
|
||||
! generic.
|
||||
SYMBOL: deferred-xts
|
||||
SYMBOL: literal-table
|
||||
|
||||
: deferred-xt deferred-xts get push ;
|
||||
: add-literal ( obj -- n )
|
||||
dup literal-table get [ eq? ] find-with drop dup -1 > [
|
||||
nip
|
||||
] [
|
||||
drop literal-table get dup length >r push r>
|
||||
] if ;
|
||||
|
||||
! To support saving compiled code to disk, generator words
|
||||
! append relocation instructions to this vector.
|
||||
SYMBOL: relocation-table
|
||||
|
||||
: rel, ( n -- ) relocation-table get push ;
|
||||
|
||||
: cell-just-compiled compiled-offset cell - ;
|
||||
|
||||
: 4-just-compiled compiled-offset 4 - ;
|
||||
|
||||
: rel-absolute-cell 0 ;
|
||||
: rel-absolute 1 ;
|
||||
: rel-relative 2 ;
|
||||
: rel-2/2 3 ;
|
||||
: rel-absolute-2/2 3 ;
|
||||
: rel-relative-2/2 4 ;
|
||||
: rel-relative-2 5 ;
|
||||
: rel-relative-3 6 ;
|
||||
|
||||
: compiled ( -- n ) building get length code-format * ;
|
||||
|
||||
: rel-type, ( arg class type -- )
|
||||
#! Write a relocation instruction for the runtime image
|
||||
#! loader.
|
||||
over >r >r >r 16 shift r> 8 shift bitor r> bitor rel,
|
||||
compiled-offset r> rel-absolute-cell = cell 4 ? - rel, ;
|
||||
compiled r> rel-absolute-cell = cell 4 ? - rel, ;
|
||||
|
||||
: rel-dlsym ( name dll class -- )
|
||||
>r 2array add-literal compiled-base - cell / r>
|
||||
1 rel-type, ;
|
||||
>r 2array add-literal r> 1 rel-type, ;
|
||||
|
||||
: rel-address ( class -- )
|
||||
#! Relocate address just compiled.
|
||||
: rel-here ( class -- )
|
||||
dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
|
||||
|
||||
: rel-word ( word class -- )
|
||||
over primitive? [
|
||||
>r word-primitive r> 0 rel-type,
|
||||
] [
|
||||
rel-address drop
|
||||
] if ;
|
||||
over primitive?
|
||||
[ >r word-primitive r> 0 ] [ >r add-literal r> 5 ] if
|
||||
rel-type, ;
|
||||
|
||||
: rel-cards ( class -- ) 0 swap 3 rel-type, ;
|
||||
|
||||
! 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 rel-relative rel-word
|
||||
compiled-offset <relative>
|
||||
4-just-compiled <fixup-4> deferred-xt ;
|
||||
|
||||
: relative-3 ( word -- )
|
||||
#! Labels only -- no image relocation information saved
|
||||
4-just-compiled <relative>
|
||||
4-just-compiled <fixup-3> deferred-xt ;
|
||||
|
||||
: relative-2 ( word -- )
|
||||
#! Labels only -- no image relocation information saved
|
||||
4-just-compiled <relative>
|
||||
4-just-compiled <fixup-2> deferred-xt ;
|
||||
|
||||
: relative-2/2 ( word -- )
|
||||
#! Labels only -- no image relocation information saved
|
||||
compiled-offset <relative>
|
||||
4-just-compiled <fixup-2/2> deferred-xt ;
|
||||
|
||||
: absolute-4 ( word -- )
|
||||
dup rel-absolute rel-word
|
||||
<absolute> 4-just-compiled <fixup-4> deferred-xt ;
|
||||
|
||||
: absolute-2/2 ( word -- )
|
||||
dup rel-2/2 rel-word
|
||||
<absolute> cell-just-compiled <fixup-2/2> deferred-xt ;
|
||||
|
||||
: absolute-cell ( word -- )
|
||||
dup rel-absolute-cell rel-word
|
||||
<absolute> cell-just-compiled <fixup-cell> deferred-xt ;
|
||||
: rel-literal ( literal class -- )
|
||||
>r add-literal r> 4 rel-type, ;
|
||||
|
||||
! When a word is encountered that has not been previously
|
||||
! compiled, it is pushed onto this vector. Compilation stops
|
||||
|
|
@ -178,16 +84,12 @@ SYMBOL: compile-words
|
|||
over compile-words get member? or
|
||||
swap compiled-xts get hash or ;
|
||||
|
||||
: fixup-xts ( -- )
|
||||
deferred-xts get [ dup resolve swap fixup ] each ;
|
||||
|
||||
: with-compiler ( quot -- )
|
||||
[
|
||||
V{ } clone deferred-xts set
|
||||
H{ } clone compiled-xts set
|
||||
V{ } clone compile-words set
|
||||
call
|
||||
fixup-xts
|
||||
finalize-compile
|
||||
commit-xts
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -289,13 +289,7 @@ sequences strings vectors words prettyprint ;
|
|||
\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
|
||||
\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ compiled-offset [ [ ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ set-compiled-offset [ [ integer ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ add-literal [ [ object ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ address [ [ object ] [ integer ] ] "infer-effect" set-word-prop
|
||||
\ add-compiled-block [ [ vector integer vector vector ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
|
||||
\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
|
||||
|
|
@ -401,7 +395,7 @@ sequences strings vectors words prettyprint ;
|
|||
|
||||
\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop
|
||||
\ finalize-compile [ [ ] [ ] ] "infer-effect" set-word-prop
|
||||
|
||||
\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@ IN: compiler
|
|||
USING: alien assembler generic kernel kernel-internals math
|
||||
memory namespaces sequences words ;
|
||||
|
||||
: code-format cell ; inline
|
||||
|
||||
! PowerPC register assignments
|
||||
! r3-r10 integer vregs
|
||||
! f0-f13 float vregs
|
||||
|
|
@ -32,9 +34,7 @@ M: immediate load-literal ( literal vreg -- )
|
|||
[ v>operand ] 2apply LOAD ;
|
||||
|
||||
M: object load-literal ( literal vreg -- )
|
||||
v>operand swap
|
||||
add-literal over
|
||||
LOAD32 rel-2/2 rel-address
|
||||
v>operand [ 0 LOAD32 rel-absolute-2/2 rel-literal ] keep
|
||||
dup 0 LWZ ;
|
||||
|
||||
: stack-increment \ stack-reserve get 32 max stack@ 16 align ;
|
||||
|
|
@ -56,7 +56,7 @@ M: object load-literal ( literal vreg -- )
|
|||
|
||||
: word-addr ( word -- )
|
||||
#! Load a word address into r3.
|
||||
dup word-xt 3 LOAD32 rel-2/2 rel-word ;
|
||||
0 3 LOAD32 rel-absolute-2/2 rel-word ;
|
||||
|
||||
: %call ( label -- )
|
||||
#! Far C call for primitives, near C call for compiled defs.
|
||||
|
|
@ -71,23 +71,22 @@ M: object load-literal ( literal vreg -- )
|
|||
%epilogue dup postpone-word %jump-label ;
|
||||
|
||||
: %jump-t ( label -- )
|
||||
0 "flag" operand f address CMPI BNE ;
|
||||
0 "flag" operand object-tag CMPI BNE ;
|
||||
|
||||
: %dispatch ( -- )
|
||||
"n" operand dup 1 SRAWI
|
||||
! The value 24 is a magic number. It is the length of the
|
||||
! instruction sequence that follows to be generated.
|
||||
compiled-offset 24 + "scratch" operand LOAD32
|
||||
rel-2/2 rel-address
|
||||
0 "scratch" operand LOAD32 rel-absolute-2/2 rel-here
|
||||
"n" operand dup "scratch" operand ADD
|
||||
"n" operand dup 0 LWZ
|
||||
"n" operand dup 24 LWZ
|
||||
"n" operand MTLR
|
||||
BLR ;
|
||||
|
||||
: %return ( -- ) %epilogue BLR ;
|
||||
|
||||
: compile-dlsym ( symbol dll register -- )
|
||||
>r 2dup dlsym r> LOAD32 rel-2/2 rel-dlsym ;
|
||||
0 swap LOAD32 rel-absolute-2/2 rel-dlsym ;
|
||||
|
||||
M: int-regs (%peek) ( vreg loc -- )
|
||||
drop >r v>operand r> loc>operand LWZ ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: assembler
|
||||
USING: compiler errors generic kernel math memory words ;
|
||||
USING: compiler errors generic kernel math memory namespaces
|
||||
words ;
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
! names are standard, and the operand order is the same as in
|
||||
|
|
@ -14,7 +15,7 @@ USING: compiler errors generic kernel math memory words ;
|
|||
!
|
||||
! 14 15 10 STW
|
||||
|
||||
: insn ( operand opcode -- ) 26 shift bitor assemble-cell ;
|
||||
: insn ( operand opcode -- ) 26 shift bitor , ;
|
||||
|
||||
: a-form ( d a b c xo rc -- n )
|
||||
>r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift
|
||||
|
|
@ -160,13 +161,13 @@ USING: compiler errors generic kernel math memory words ;
|
|||
|
||||
G: (B) ( dest aa lk -- ) 2 standard-combination ;
|
||||
M: integer (B) i-form 18 insn ;
|
||||
M: word (B) 0 -rot (B) relative-3 ;
|
||||
M: word (B) 0 -rot (B) rel-relative-3 rel-word ;
|
||||
|
||||
: B 0 0 (B) ; : BL 0 1 (B) ;
|
||||
|
||||
GENERIC: BC
|
||||
M: integer BC 0 0 b-form 16 insn ;
|
||||
M: word BC >r 0 BC r> relative-2 ;
|
||||
M: word BC >r 0 BC r> rel-relative-2 rel-word ;
|
||||
|
||||
: BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
|
||||
: BGT 12 1 rot BC ; : BLE 4 1 rot BC ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: immediate load-literal ( literal vreg -- )
|
|||
v>operand swap v>operand MOV ;
|
||||
|
||||
: load-indirect ( literal reg -- )
|
||||
swap add-literal [] MOV rel-absolute-cell rel-address ;
|
||||
0 [] MOV rel-absolute-cell rel-literal ;
|
||||
|
||||
M: object load-literal ( literal vreg -- )
|
||||
v>operand load-indirect ;
|
||||
|
|
@ -116,7 +116,8 @@ M: object load-literal ( literal vreg -- )
|
|||
! Add to jump table base. We use a temporary register since
|
||||
! on AMD64 we have to load a 64-bit immediate. On x86, this
|
||||
! is redundant.
|
||||
"scratch" operand HEX: ffffffff MOV "end" get absolute-cell
|
||||
"scratch" operand HEX: ffffffff MOV
|
||||
"end" get rel-absolute-cell rel-word
|
||||
"n" operand "scratch" operand ADD
|
||||
! Jump to jump table entry
|
||||
"n" operand [] JMP
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
USING: arrays compiler errors generic kernel kernel-internals
|
||||
USING: arrays compiler errors generic io kernel kernel-internals
|
||||
math namespaces parser sequences words ;
|
||||
IN: assembler
|
||||
|
||||
|
|
@ -10,6 +10,9 @@ IN: assembler
|
|||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
! Beware!
|
||||
|
||||
: 4, 4 >le % ; inline
|
||||
: cell, cell >le % ; inline
|
||||
|
||||
#! Extended AMD64 registers (R8-R15) return true.
|
||||
GENERIC: extended? ( op -- ? )
|
||||
|
||||
|
|
@ -183,9 +186,9 @@ M: indirect displacement indirect-displacement ;
|
|||
M: register displacement drop f ;
|
||||
|
||||
: addressing ( reg# indirect -- )
|
||||
[ mod-r/m assemble-1 ] keep
|
||||
[ sib [ assemble-1 ] when* ] keep
|
||||
displacement [ assemble-4 ] when* ;
|
||||
[ mod-r/m , ] keep
|
||||
[ sib [ , ] when* ] keep
|
||||
displacement [ 4, ] when* ;
|
||||
|
||||
( Utilities )
|
||||
UNION: operand register indirect ;
|
||||
|
|
@ -217,10 +220,10 @@ UNION: operand register indirect ;
|
|||
#! Compile an AMD64 REX prefix.
|
||||
pick pick rex.w? BIN: 01001000 BIN: 01000000 ?
|
||||
swap lhs-prefix swap rhs-prefix
|
||||
dup BIN: 01000000 = [ drop ] [ assemble-1 ] if ;
|
||||
dup BIN: 01000000 = [ drop ] [ , ] if ;
|
||||
|
||||
: 16-prefix ( reg r/m -- )
|
||||
[ register-16? ] 2apply or [ HEX: 66 assemble-1 ] when ;
|
||||
[ register-16? ] 2apply or [ HEX: 66 , ] when ;
|
||||
|
||||
: prefix ( reg r/m rex.w -- ) pick pick 16-prefix rex-prefix ;
|
||||
|
||||
|
|
@ -229,15 +232,15 @@ UNION: operand register indirect ;
|
|||
: short-operand ( reg rex.w n -- )
|
||||
#! Some instructions encode their single operand as part of
|
||||
#! the opcode.
|
||||
>r dupd prefix-1 reg-code r> + assemble-1 ;
|
||||
>r dupd prefix-1 reg-code r> + , ;
|
||||
|
||||
: 1-operand ( op reg rex.w opcode -- )
|
||||
#! The 'reg' is not really a register, but a value for the
|
||||
#! 'reg' field of the mod-r/m byte.
|
||||
>r >r over r> prefix-1 r> assemble-1 swap addressing ;
|
||||
>r >r over r> prefix-1 r> , swap addressing ;
|
||||
|
||||
: immediate-1 ( imm dst reg rex.w opcode -- )
|
||||
1-operand assemble-1 ;
|
||||
1-operand , ;
|
||||
|
||||
: immediate-1/4 ( imm dst reg rex.w opcode -- )
|
||||
#! If imm is a byte, compile the opcode and the byte.
|
||||
|
|
@ -247,26 +250,22 @@ UNION: operand register indirect ;
|
|||
>r >r pick byte? [
|
||||
r> r> BIN: 10 bitor immediate-1
|
||||
] [
|
||||
r> r> 1-operand assemble-4
|
||||
r> r> 1-operand 4,
|
||||
] if ;
|
||||
|
||||
: 2-operand ( dst src op -- )
|
||||
#! Sets the opcode's direction bit. It is set if the
|
||||
#! destination is a direct register operand.
|
||||
pick register? [ BIN: 10 bitor swapd ] when
|
||||
>r 2dup t prefix r> assemble-1 reg-code swap addressing ;
|
||||
|
||||
: from ( addr -- addr )
|
||||
#! Relative to after next 32-bit immediate.
|
||||
compiled-offset - 4 - ;
|
||||
>r 2dup t prefix r> , reg-code swap addressing ;
|
||||
|
||||
PREDICATE: word callable register? not ;
|
||||
|
||||
( Moving stuff )
|
||||
GENERIC: PUSH ( op -- )
|
||||
M: register PUSH f HEX: 50 short-operand ;
|
||||
M: integer PUSH HEX: 68 assemble-1 assemble-4 ;
|
||||
M: callable PUSH 0 PUSH absolute-4 ;
|
||||
M: integer PUSH HEX: 68 , 4, ;
|
||||
M: callable PUSH 0 PUSH rel-absolute rel-word ;
|
||||
M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
|
||||
|
||||
GENERIC: POP ( op -- )
|
||||
|
|
@ -275,30 +274,30 @@ M: operand POP BIN: 000 f HEX: 8f 1-operand ;
|
|||
|
||||
! MOV where the src is immediate.
|
||||
GENERIC: (MOV-I) ( src dst -- )
|
||||
M: register (MOV-I) t HEX: b8 short-operand assemble-cell ;
|
||||
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand assemble-4 ;
|
||||
M: register (MOV-I) t HEX: b8 short-operand cell, ;
|
||||
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: integer MOV swap (MOV-I) ;
|
||||
M: callable MOV 0 rot (MOV-I) absolute-cell ;
|
||||
M: callable MOV 0 rot (MOV-I) rel-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 89 2-operand ;
|
||||
|
||||
( Control flow )
|
||||
GENERIC: JMP ( op -- )
|
||||
M: integer JMP HEX: e9 assemble-1 from assemble-4 ;
|
||||
M: callable JMP 0 JMP relative-4 ;
|
||||
! M: integer JMP HEX: e9 , from 4, ;
|
||||
M: callable JMP 0 JMP rel-relative rel-word ;
|
||||
M: operand JMP BIN: 100 t HEX: ff 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
M: integer CALL HEX: e8 assemble-1 from assemble-4 ;
|
||||
M: callable CALL 0 CALL relative-4 ;
|
||||
! M: integer CALL HEX: e8 , from 4, ;
|
||||
M: callable CALL 0 CALL rel-relative rel-word ;
|
||||
M: operand CALL BIN: 010 t HEX: ff 1-operand ;
|
||||
|
||||
G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
|
||||
M: integer JUMPcc ( addr opcode -- )
|
||||
swap HEX: 0f assemble-1 swap assemble-1 from assemble-4 ;
|
||||
! M: integer JUMPcc ( addr opcode -- )
|
||||
! swap HEX: 0f , swap , from assemble-4 ;
|
||||
M: callable JUMPcc ( addr opcode -- )
|
||||
swap >r 0 swap JUMPcc r> relative-4 ;
|
||||
swap >r 0 swap JUMPcc r> rel-relative rel-word ;
|
||||
|
||||
: JO HEX: 80 JUMPcc ;
|
||||
: JNO HEX: 81 JUMPcc ;
|
||||
|
|
@ -317,7 +316,7 @@ M: callable JUMPcc ( addr opcode -- )
|
|||
: JLE HEX: 8e JUMPcc ;
|
||||
: JG HEX: 8f JUMPcc ;
|
||||
|
||||
: RET ( -- ) HEX: c3 assemble-1 ;
|
||||
: RET ( -- ) HEX: c3 , ;
|
||||
|
||||
( Arithmetic )
|
||||
|
||||
|
|
@ -363,8 +362,8 @@ M: operand CMP OCT: 071 2-operand ;
|
|||
GENERIC: IMUL2 ( dst src -- )
|
||||
M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
|
||||
|
||||
: CDQ HEX: 99 assemble-1 ;
|
||||
: CQO HEX: 48 assemble-1 CDQ ;
|
||||
: CDQ HEX: 99 , ;
|
||||
: CQO HEX: 48 , CDQ ;
|
||||
|
||||
: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
|
||||
: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
|
||||
|
|
@ -387,9 +386,9 @@ M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
|
|||
: 2-operand-sse ( dst src op1 op2 -- )
|
||||
#! We swap the operands here to make everything consistent
|
||||
#! with the integer instructions.
|
||||
swap assemble-1 pick register-128? [ swapd ] [ 1 bitor ] if
|
||||
>r 2dup t prefix HEX: 0f assemble-1 r>
|
||||
assemble-1 reg-code swap addressing ;
|
||||
swap , pick register-128? [ swapd ] [ 1 bitor ] if
|
||||
>r 2dup t prefix HEX: 0f , r>
|
||||
, reg-code swap addressing ;
|
||||
|
||||
: MOVSS ( dest src -- ) HEX: f3 HEX: 10 2-operand-sse ;
|
||||
: MOVSD ( dest src -- ) HEX: f2 HEX: 10 2-operand-sse ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: math
|
||||
USING: errors generic kernel kernel-internals sequences
|
||||
sequences-internals ;
|
||||
|
|
@ -28,6 +28,14 @@ UNION: integer fixnum bignum ;
|
|||
|
||||
: next-power-of-2 ( n -- n ) 2 swap (next-power-of-2) ;
|
||||
|
||||
: d>w/w ( d -- w w )
|
||||
dup HEX: ffffffff bitand
|
||||
swap -32 shift HEX: ffffffff bitand ;
|
||||
|
||||
: w>h/h ( w -- h h )
|
||||
dup HEX: ffff bitand
|
||||
swap -16 shift HEX: ffff bitand ;
|
||||
|
||||
IN: math-internals
|
||||
|
||||
: fraction> ( a b -- a/b )
|
||||
|
|
|
|||
|
|
@ -54,11 +54,11 @@ USE: optimizer
|
|||
[ t ] [ [ [ 1 ] [ 2 ] ] [ [ 1 ] [ 2 ] if ] kill-set= ] unit-test
|
||||
|
||||
|
||||
: literal-kill-test-1 4 compiled-offset 2 cells - ; compiled
|
||||
: literal-kill-test-1 4 cell 2 cells - ; compiled
|
||||
|
||||
[ 4 ] [ literal-kill-test-1 drop ] unit-test
|
||||
|
||||
: literal-kill-test-2 3 compiled-offset 2 cells - ; compiled
|
||||
: literal-kill-test-2 3 cell 2 cells - ; compiled
|
||||
|
||||
[ 3 ] [ literal-kill-test-2 drop ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,6 @@
|
|||
IN: memory
|
||||
USING: errors help test ;
|
||||
|
||||
HELP: address "( obj -- n )"
|
||||
{ $values { "obj" "an object" } { "n" "a memory address" } }
|
||||
{ $description "Outputs the address of an object in memory. Objects can be moved around by the garbage collector and there is almost never any reason for user code to need to know object addresses." } ;
|
||||
|
||||
HELP: gc "( n -- )"
|
||||
{ $values { "n" "a positive integer" } }
|
||||
{ $description "Collects all generations up to and including the " { $snippet "n" } "th generation. The nursery where new objects are allocated is generation 0, and tenured space is generation " { $snippet "g-1" } " where " { $snippet "g" } " is the value output by " { $link generations } "." } ;
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
|
||||
void init_factor(const char* image,
|
||||
CELL ds_size, CELL rs_size, CELL cs_size,
|
||||
CELL gen_count, CELL young_size, CELL aging_size,
|
||||
CELL code_size, CELL literal_size)
|
||||
CELL gen_count, CELL young_size, CELL aging_size, CELL code_size)
|
||||
{
|
||||
init_ffi();
|
||||
init_arena(gen_count,young_size,aging_size);
|
||||
|
|
@ -13,7 +12,7 @@ void init_factor(const char* image,
|
|||
callframe = F;
|
||||
callframe_scan = callframe_end = 0;
|
||||
thrown_error = F;
|
||||
load_image(image,literal_size);
|
||||
load_image(image);
|
||||
call(userenv[BOOT_ENV]);
|
||||
init_c_io();
|
||||
init_signals();
|
||||
|
|
@ -48,7 +47,6 @@ int main(int argc, char** argv)
|
|||
CELL young_size = 2 * CELLS;
|
||||
CELL aging_size = 4 * CELLS;
|
||||
CELL code_size = CELLS;
|
||||
CELL literal_size = 128;
|
||||
F_ARRAY *args;
|
||||
CELL arg_count;
|
||||
CELL i;
|
||||
|
|
@ -83,8 +81,7 @@ int main(int argc, char** argv)
|
|||
generations,
|
||||
young_size * 1024 * 1024,
|
||||
aging_size * 1024 * 1024,
|
||||
code_size * 1024 * 1024,
|
||||
literal_size * 1024);
|
||||
code_size * 1024 * 1024);
|
||||
|
||||
arg_count = (image_given ? 2 : 1);
|
||||
args = array(ARRAY_TYPE,argc,F);
|
||||
|
|
|
|||
203
vm/image.c
203
vm/image.c
|
|
@ -13,11 +13,10 @@ void init_objects(HEADER *h)
|
|||
bignum_neg_one = h->bignum_neg_one;
|
||||
}
|
||||
|
||||
void load_image(const char* filename, int literal_table)
|
||||
void load_image(const char* filename)
|
||||
{
|
||||
FILE* file;
|
||||
HEADER h;
|
||||
HEADER_2 ext_h;
|
||||
|
||||
file = fopen(filename,"rb");
|
||||
if(file == NULL)
|
||||
|
|
@ -29,54 +28,39 @@ void load_image(const char* filename, int literal_table)
|
|||
|
||||
printf("Loading %s...",filename);
|
||||
|
||||
/* read header */
|
||||
{
|
||||
/* read it in native byte order */
|
||||
fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
|
||||
|
||||
if(h.magic != IMAGE_MAGIC)
|
||||
fatal_error("Bad magic number",h.magic);
|
||||
|
||||
if(h.version == IMAGE_VERSION)
|
||||
fread(&ext_h,sizeof(HEADER_2)/sizeof(CELL),sizeof(CELL),file);
|
||||
else if(h.version == IMAGE_VERSION_0)
|
||||
{
|
||||
ext_h.size = literal_table;
|
||||
ext_h.literal_top = 0;
|
||||
ext_h.literal_max = literal_table;
|
||||
ext_h.relocation_base = compiling.base;
|
||||
}
|
||||
else
|
||||
if(h.version != IMAGE_VERSION)
|
||||
fatal_error("Bad version number",h.version);
|
||||
}
|
||||
|
||||
/* read data heap */
|
||||
{
|
||||
CELL size = h.size / CELLS;
|
||||
allot(h.size);
|
||||
CELL size = h.data_size / CELLS;
|
||||
allot(h.data_size);
|
||||
|
||||
if(size != fread((void*)tenured.base,sizeof(CELL),size,file))
|
||||
fatal_error("Wrong data heap length",h.size);
|
||||
fatal_error("Wrong data heap length",h.data_size);
|
||||
|
||||
tenured.here = tenured.base + h.size;
|
||||
data_relocation_base = h.relocation_base;
|
||||
tenured.here = tenured.base + h.data_size;
|
||||
data_relocation_base = h.data_relocation_base;
|
||||
}
|
||||
|
||||
/* read code heap */
|
||||
{
|
||||
CELL size = ext_h.size;
|
||||
CELL size = h.code_size;
|
||||
if(size + compiling.base >= compiling.limit)
|
||||
fatal_error("Code heap too large",ext_h.size);
|
||||
fatal_error("Code heap too large",h.code_size);
|
||||
|
||||
if(h.version == IMAGE_VERSION
|
||||
&& size != fread((void*)compiling.base,1,size,file))
|
||||
fatal_error("Wrong code heap length",ext_h.size);
|
||||
fatal_error("Wrong code heap length",h.code_size);
|
||||
|
||||
compiling.here = compiling.base + ext_h.size;
|
||||
literal_top = compiling.base + ext_h.literal_top;
|
||||
literal_max = compiling.base + ext_h.literal_max;
|
||||
compiling.here = compiling.base + ext_h.size;
|
||||
code_relocation_base = ext_h.relocation_base;
|
||||
compiling.here = compiling.base + h.code_size;
|
||||
code_relocation_base = h.code_relocation_base;
|
||||
}
|
||||
|
||||
fclose(file);
|
||||
|
|
@ -97,7 +81,6 @@ bool save_image(const char* filename)
|
|||
{
|
||||
FILE* file;
|
||||
HEADER h;
|
||||
HEADER_2 ext_h;
|
||||
|
||||
fprintf(stderr,"Saving %s...\n",filename);
|
||||
|
||||
|
|
@ -107,24 +90,20 @@ bool save_image(const char* filename)
|
|||
|
||||
h.magic = IMAGE_MAGIC;
|
||||
h.version = IMAGE_VERSION;
|
||||
h.relocation_base = tenured.base;
|
||||
h.data_relocation_base = tenured.base;
|
||||
h.boot = userenv[BOOT_ENV];
|
||||
h.size = tenured.here - tenured.base;
|
||||
h.data_size = tenured.here - tenured.base;
|
||||
h.global = userenv[GLOBAL_ENV];
|
||||
h.t = T;
|
||||
h.bignum_zero = bignum_zero;
|
||||
h.bignum_pos_one = bignum_pos_one;
|
||||
h.bignum_neg_one = bignum_neg_one;
|
||||
h.code_size = compiling.here - compiling.base;
|
||||
h.code_relocation_base = compiling.base;
|
||||
fwrite(&h,sizeof(HEADER),1,file);
|
||||
|
||||
ext_h.size = compiling.here - compiling.base;
|
||||
ext_h.literal_top = literal_top - compiling.base;
|
||||
ext_h.literal_max = literal_max - compiling.base;
|
||||
ext_h.relocation_base = compiling.base;
|
||||
fwrite(&ext_h,sizeof(HEADER_2),1,file);
|
||||
|
||||
fwrite((void*)tenured.base,h.size,1,file);
|
||||
fwrite((void*)compiling.base,ext_h.size,1,file);
|
||||
fwrite((void*)tenured.base,h.data_size,1,file);
|
||||
fwrite((void*)compiling.base,h.code_size,1,file);
|
||||
|
||||
fclose(file);
|
||||
|
||||
|
|
@ -189,13 +168,6 @@ void relocate_data()
|
|||
allot_barrier(relocating);
|
||||
relocate_object(relocating);
|
||||
}
|
||||
|
||||
for(relocating = compiling.base;
|
||||
relocating < literal_top;
|
||||
relocating += CELLS)
|
||||
{
|
||||
data_fixup((CELL*)relocating);
|
||||
}
|
||||
}
|
||||
|
||||
void undefined_symbol(void)
|
||||
|
|
@ -203,10 +175,17 @@ void undefined_symbol(void)
|
|||
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
|
||||
}
|
||||
|
||||
CELL get_rel_symbol(F_REL* rel)
|
||||
#define LITERAL_REF(literal_start,num) ((literal_start) + CELLS * (num))
|
||||
|
||||
INLINE CELL get_literal(CELL literal_start, CELL num)
|
||||
{
|
||||
return get(LITERAL_REF(literal_start,num));
|
||||
}
|
||||
|
||||
CELL get_rel_symbol(F_REL *rel, CELL literal_start)
|
||||
{
|
||||
CELL arg = REL_ARGUMENT(rel);
|
||||
F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
|
||||
F_ARRAY *pair = untag_array(get_literal(literal_start,arg));
|
||||
F_STRING *symbol = untag_string(get(AREF(pair,0)));
|
||||
CELL library = get(AREF(pair,1));
|
||||
DLL *dll = (library == F ? NULL : untag_dll(library));
|
||||
|
|
@ -223,99 +202,141 @@ CELL get_rel_symbol(F_REL* rel)
|
|||
return sym;
|
||||
}
|
||||
|
||||
INLINE CELL compute_code_rel(F_REL *rel, CELL original)
|
||||
CELL get_rel_word(F_REL *rel, CELL literal_start)
|
||||
{
|
||||
CELL arg = REL_ARGUMENT(rel);
|
||||
F_WORD *word = untag_word(get_literal(literal_start,arg));
|
||||
return (CELL)word->xt;
|
||||
}
|
||||
|
||||
INLINE CELL compute_code_rel(F_REL *rel, CELL original,
|
||||
CELL offset, CELL literal_start)
|
||||
{
|
||||
switch(REL_TYPE(rel))
|
||||
{
|
||||
case F_PRIMITIVE:
|
||||
case RT_PRIMITIVE:
|
||||
return primitive_to_xt(REL_ARGUMENT(rel));
|
||||
case F_DLSYM:
|
||||
return get_rel_symbol(rel);
|
||||
case F_ABSOLUTE:
|
||||
return original + (compiling.base - code_relocation_base);
|
||||
case F_CARDS:
|
||||
case RT_DLSYM:
|
||||
return get_rel_symbol(rel,literal_start);
|
||||
case RT_HERE:
|
||||
return offset;
|
||||
case RT_CARDS:
|
||||
return cards_offset;
|
||||
case RT_LITERAL:
|
||||
return LITERAL_REF(literal_start,REL_ARGUMENT(rel));
|
||||
case RT_WORD:
|
||||
return get_rel_word(rel,literal_start);
|
||||
default:
|
||||
critical_error("Unsupported rel type",rel->type);
|
||||
return -1;
|
||||
}
|
||||
}
|
||||
|
||||
INLINE CELL relocate_code_next(CELL relocating)
|
||||
{
|
||||
F_COMPILED* compiled = (F_COMPILED*)relocating;
|
||||
|
||||
F_REL* rel = (F_REL*)(
|
||||
relocating + sizeof(F_COMPILED)
|
||||
+ compiled->code_length);
|
||||
|
||||
F_REL* rel_end = (F_REL*)(
|
||||
relocating + sizeof(F_COMPILED)
|
||||
+ compiled->code_length
|
||||
+ compiled->reloc_length);
|
||||
|
||||
if(compiled->header != COMPILED_HEADER)
|
||||
critical_error("Wrong compiled header",relocating);
|
||||
|
||||
while(rel < rel_end)
|
||||
INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
|
||||
{
|
||||
CELL original;
|
||||
CELL new_value;
|
||||
|
||||
code_fixup(&rel->offset);
|
||||
CELL offset = rel->offset + code_start;
|
||||
|
||||
switch(REL_CLASS(rel))
|
||||
{
|
||||
case REL_ABSOLUTE_CELL:
|
||||
original = get(rel->offset);
|
||||
original = get(offset);
|
||||
break;
|
||||
case REL_ABSOLUTE:
|
||||
original = *(u32*)rel->offset;
|
||||
original = *(u32*)offset;
|
||||
break;
|
||||
case REL_RELATIVE:
|
||||
original = *(u32*)rel->offset - (rel->offset + sizeof(u32));
|
||||
original = *(u32*)offset - (offset + sizeof(u32));
|
||||
break;
|
||||
case REL_2_2:
|
||||
original = reloc_get_2_2(rel->offset);
|
||||
case REL_ABSOLUTE_2_2:
|
||||
original = reloc_get_2_2(offset);
|
||||
break;
|
||||
case REL_RELATIVE_2_2:
|
||||
original = reloc_get_2_2(offset) - (offset + sizeof(u32));
|
||||
break;
|
||||
case REL_RELATIVE_2:
|
||||
original = *(u32*)offset;
|
||||
original &= REL_RELATIVE_2_MASK;
|
||||
break;
|
||||
case REL_RELATIVE_3:
|
||||
original = *(u32*)offset;
|
||||
original &= REL_RELATIVE_3_MASK;
|
||||
break;
|
||||
default:
|
||||
critical_error("Unsupported rel class",REL_CLASS(rel));
|
||||
return -1;
|
||||
return;
|
||||
}
|
||||
|
||||
/* to_c_string can fill up the heap */
|
||||
maybe_gc(0);
|
||||
new_value = compute_code_rel(rel,original);
|
||||
new_value = compute_code_rel(rel,original,offset,literal_start);
|
||||
|
||||
switch(REL_CLASS(rel))
|
||||
{
|
||||
case REL_ABSOLUTE_CELL:
|
||||
put(rel->offset,new_value);
|
||||
put(offset,new_value);
|
||||
break;
|
||||
case REL_ABSOLUTE:
|
||||
*(u32*)rel->offset = new_value;
|
||||
*(u32*)offset = new_value;
|
||||
break;
|
||||
case REL_RELATIVE:
|
||||
*(u32*)rel->offset = new_value - (rel->offset + CELLS);
|
||||
*(u32*)offset = new_value - (offset + sizeof(u32));
|
||||
break;
|
||||
case REL_2_2:
|
||||
reloc_set_2_2(rel->offset,new_value);
|
||||
case REL_ABSOLUTE_2_2:
|
||||
reloc_set_2_2(offset,new_value);
|
||||
break;
|
||||
case REL_RELATIVE_2_2:
|
||||
reloc_set_2_2(offset,new_value - (offset + sizeof(u32)));
|
||||
break;
|
||||
case REL_RELATIVE_2:
|
||||
original = *(u32*)offset;
|
||||
original &= ~REL_RELATIVE_2_MASK;
|
||||
*(u32*)offset = (original | new_value);
|
||||
break;
|
||||
case REL_RELATIVE_3:
|
||||
original = *(u32*)offset;
|
||||
original &= ~REL_RELATIVE_3_MASK;
|
||||
*(u32*)offset = (original | new_value);
|
||||
break;
|
||||
default:
|
||||
critical_error("Unsupported rel class",REL_CLASS(rel));
|
||||
return -1;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
rel++;
|
||||
}
|
||||
CELL relocate_code_next(CELL relocating)
|
||||
{
|
||||
F_COMPILED* compiled = (F_COMPILED*)relocating;
|
||||
|
||||
return (CELL)rel_end;
|
||||
if(compiled->header != COMPILED_HEADER)
|
||||
critical_error("Wrong compiled header",relocating);
|
||||
|
||||
CELL code_start = relocating + sizeof(F_COMPILED);
|
||||
CELL reloc_start = code_start + compiled->code_length;
|
||||
CELL literal_start = reloc_start + compiled->reloc_length;
|
||||
|
||||
F_REL *rel = (F_REL *)reloc_start;
|
||||
F_REL *rel_end = (F_REL *)literal_start;
|
||||
|
||||
/* apply relocations */
|
||||
while(rel < rel_end)
|
||||
relocate_code_step(rel++,code_start,literal_start);
|
||||
|
||||
CELL *scan = (CELL*)literal_start;
|
||||
CELL *literal_end = (CELL*)(literal_start + compiled->literal_length);
|
||||
|
||||
/* relocate literal table data */
|
||||
while(scan < literal_end)
|
||||
data_fixup(scan++);
|
||||
|
||||
return (CELL)literal_end;
|
||||
}
|
||||
|
||||
void relocate_code()
|
||||
{
|
||||
/* start relocating from the end of the space reserved for literals */
|
||||
CELL relocating = literal_max;
|
||||
CELL relocating = compiling.base;
|
||||
while(relocating < compiling.here)
|
||||
relocating = relocate_code_next(relocating);
|
||||
}
|
||||
|
|
|
|||
52
vm/image.h
52
vm/image.h
|
|
@ -1,13 +1,12 @@
|
|||
#define IMAGE_MAGIC 0x0f0e0d0c
|
||||
#define IMAGE_VERSION_0 0
|
||||
#define IMAGE_VERSION 1
|
||||
#define IMAGE_VERSION 2
|
||||
|
||||
typedef struct {
|
||||
CELL magic;
|
||||
CELL version;
|
||||
/* all pointers in the image file are relocated from
|
||||
relocation_base to here when the image is loaded */
|
||||
CELL relocation_base;
|
||||
CELL data_relocation_base;
|
||||
/* tagged pointer to bootstrap quotation */
|
||||
CELL boot;
|
||||
/* tagged pointer to global namespace */
|
||||
|
|
@ -21,23 +20,15 @@ typedef struct {
|
|||
/* tagged pointer to bignum -1 */
|
||||
CELL bignum_neg_one;
|
||||
/* size of heap */
|
||||
CELL size;
|
||||
CELL data_size;
|
||||
/* size of code heap */
|
||||
CELL code_size;
|
||||
/* code relocation base */
|
||||
CELL code_relocation_base;
|
||||
} HEADER;
|
||||
|
||||
/* If version is IMAGE_VERSION_1 */
|
||||
typedef struct EXT_HEADER {
|
||||
/* size of code heap */
|
||||
CELL size;
|
||||
/* code relocation base */
|
||||
CELL relocation_base;
|
||||
/* end of literal table */
|
||||
CELL literal_top;
|
||||
/* maximum value of literal_top */
|
||||
CELL literal_max;
|
||||
} HEADER_2;
|
||||
|
||||
void init_objects(HEADER *h);
|
||||
void load_image(const char* file, int literal_size);
|
||||
void load_image(const char* file);
|
||||
bool save_image(const char* file);
|
||||
void primitive_save_image(void);
|
||||
|
||||
|
|
@ -52,20 +43,29 @@ INLINE void data_fixup(CELL *cell)
|
|||
|
||||
typedef enum {
|
||||
/* arg is a primitive number */
|
||||
F_PRIMITIVE,
|
||||
/* arg is a pointer in the literal table hodling a cons where the
|
||||
car is a symbol string, and the cdr is a dll */
|
||||
F_DLSYM,
|
||||
/* relocate an address to start of code heap */
|
||||
F_ABSOLUTE,
|
||||
RT_PRIMITIVE,
|
||||
/* arg is a literal table index, holding an array pair (symbol/dll) */
|
||||
RT_DLSYM,
|
||||
/* store current address here */
|
||||
RT_HERE,
|
||||
/* store the offset of the card table from the data heap base */
|
||||
F_CARDS
|
||||
RT_CARDS,
|
||||
/* an indirect literal from the word's literal table */
|
||||
RT_LITERAL,
|
||||
/* a word */
|
||||
RT_WORD
|
||||
} F_RELTYPE;
|
||||
|
||||
#define REL_ABSOLUTE_CELL 0
|
||||
#define REL_ABSOLUTE 1
|
||||
#define REL_RELATIVE 2
|
||||
#define REL_2_2 3
|
||||
#define REL_ABSOLUTE_2_2 3
|
||||
#define REL_RELATIVE_2_2 4
|
||||
#define REL_RELATIVE_2 5
|
||||
#define REL_RELATIVE_3 6
|
||||
|
||||
#define REL_RELATIVE_2_MASK 0x3fffffc
|
||||
#define REL_RELATIVE_3_MASK 0xfffc
|
||||
|
||||
/* the rel type is built like a cell to avoid endian-specific code in
|
||||
the compiler */
|
||||
|
|
@ -87,6 +87,8 @@ INLINE void code_fixup(CELL *cell)
|
|||
}
|
||||
|
||||
void relocate_data();
|
||||
|
||||
CELL relocate_code_next(CELL relocating);
|
||||
void relocate_code();
|
||||
|
||||
/* on PowerPC, return the 32-bit literal being loaded at the code at the
|
||||
|
|
|
|||
|
|
@ -140,11 +140,6 @@ void primitive_set_integer_slot(void)
|
|||
put(SLOT(obj,slot),value);
|
||||
}
|
||||
|
||||
void primitive_address(void)
|
||||
{
|
||||
drepl(tag_bignum(s48_cell_to_bignum(dpeek())));
|
||||
}
|
||||
|
||||
void primitive_size(void)
|
||||
{
|
||||
drepl(tag_fixnum(object_size(dpeek())));
|
||||
|
|
|
|||
|
|
@ -94,7 +94,6 @@ void primitive_slot(void);
|
|||
void primitive_set_slot(void);
|
||||
void primitive_integer_slot(void);
|
||||
void primitive_set_integer_slot(void);
|
||||
void primitive_address(void);
|
||||
void primitive_size(void);
|
||||
CELL clone(CELL obj);
|
||||
void primitive_clone(void);
|
||||
|
|
|
|||
|
|
@ -121,10 +121,7 @@ void* primitives[] = {
|
|||
primitive_tag,
|
||||
primitive_cwd,
|
||||
primitive_cd,
|
||||
primitive_compiled_offset,
|
||||
primitive_set_compiled_offset,
|
||||
primitive_add_literal,
|
||||
primitive_address,
|
||||
primitive_add_compiled_block,
|
||||
primitive_dlopen,
|
||||
primitive_dlsym,
|
||||
primitive_dlclose,
|
||||
|
|
@ -178,7 +175,7 @@ void* primitives[] = {
|
|||
primitive_end_scan,
|
||||
primitive_size,
|
||||
primitive_die,
|
||||
primitive_flush_icache,
|
||||
primitive_finalize_compile,
|
||||
primitive_fopen,
|
||||
primitive_fgetc,
|
||||
primitive_fwrite,
|
||||
|
|
|
|||
118
vm/run.c
118
vm/run.c
|
|
@ -277,49 +277,95 @@ void type_error(CELL type, CELL tagged)
|
|||
|
||||
void init_compiler(CELL size)
|
||||
{
|
||||
compiling.base = compiling.here = (CELL)(alloc_bounded_block(size)->start);
|
||||
compiling.base = compiling.here
|
||||
= (CELL)(alloc_bounded_block(size)->start);
|
||||
if(compiling.base == 0)
|
||||
fatal_error("Cannot allocate code heap",size);
|
||||
compiling.limit = compiling.base + size;
|
||||
last_flush = compiling.base;
|
||||
}
|
||||
|
||||
void primitive_compiled_offset(void)
|
||||
{
|
||||
box_unsigned_cell(compiling.here);
|
||||
}
|
||||
|
||||
void primitive_set_compiled_offset(void)
|
||||
{
|
||||
CELL offset = unbox_unsigned_cell();
|
||||
compiling.here = offset;
|
||||
if(compiling.here >= compiling.limit)
|
||||
{
|
||||
fprintf(stderr,"Code space exhausted\n");
|
||||
factorbug();
|
||||
}
|
||||
}
|
||||
|
||||
void primitive_add_literal(void)
|
||||
{
|
||||
CELL object = dpeek();
|
||||
CELL offset = literal_top;
|
||||
put(literal_top,object);
|
||||
literal_top += CELLS;
|
||||
if(literal_top >= literal_max)
|
||||
critical_error("Too many compiled literals",literal_top);
|
||||
drepl(tag_cell(offset));
|
||||
}
|
||||
|
||||
void primitive_flush_icache(void)
|
||||
{
|
||||
flush_icache((void*)last_flush,compiling.here - last_flush);
|
||||
last_flush = compiling.here;
|
||||
}
|
||||
|
||||
void collect_literals(void)
|
||||
{
|
||||
CELL i;
|
||||
/* CELL i;
|
||||
for(i = compiling.base; i < literal_top; i += CELLS)
|
||||
copy_handle((CELL*)i);
|
||||
copy_handle((CELL*)i); */
|
||||
}
|
||||
|
||||
void deposit_vector(F_VECTOR *vector, CELL format)
|
||||
{
|
||||
CELL count = untag_fixnum_fast(vector->top);
|
||||
F_ARRAY *array = untag_array_fast(vector->array);
|
||||
CELL i;
|
||||
|
||||
if(format == 1)
|
||||
{
|
||||
for(i = 0; i < count; i++)
|
||||
cput(compiling.here + i,to_fixnum(get(AREF(array,i))));
|
||||
}
|
||||
else if(format == CELLS)
|
||||
{
|
||||
CELL dest = compiling.here;
|
||||
|
||||
for(i = 0; i < count; i++)
|
||||
{
|
||||
put(dest,to_fixnum(get(AREF(array,i))));
|
||||
dest += CELLS;
|
||||
}
|
||||
}
|
||||
else
|
||||
fatal_error("Bad format param to deposit_vector()",format);
|
||||
|
||||
compiling.here += count * format;
|
||||
}
|
||||
|
||||
void add_compiled_block(F_VECTOR *code, CELL code_format,
|
||||
F_VECTOR *reloc, F_VECTOR *literals)
|
||||
{
|
||||
CELL start = compiling.here;
|
||||
CELL code_length = untag_fixnum_fast(code->top) * code_format;
|
||||
CELL reloc_length = untag_fixnum_fast(reloc->top) * CELLS;
|
||||
CELL literal_length = untag_fixnum_fast(literals->top) * CELLS;
|
||||
|
||||
/* compiled header */
|
||||
F_COMPILED header;
|
||||
header.header = COMPILED_HEADER;
|
||||
header.code_length = align8(code_length);
|
||||
header.reloc_length = reloc_length;
|
||||
header.literal_length = literal_length;
|
||||
memcpy((void*)compiling.here,&header,sizeof(F_COMPILED));
|
||||
compiling.here += sizeof(F_COMPILED);
|
||||
|
||||
/* code */
|
||||
deposit_vector(code,code_format);
|
||||
compiling.here = align8(compiling.here);
|
||||
|
||||
/* relocation info */
|
||||
deposit_vector(reloc,CELLS);
|
||||
|
||||
/* literals */
|
||||
deposit_vector(literals,CELLS);
|
||||
|
||||
/* push the XT of the new word on the stack */
|
||||
box_unsigned_cell(start + sizeof(F_COMPILED));
|
||||
}
|
||||
|
||||
void primitive_add_compiled_block(void)
|
||||
{
|
||||
F_VECTOR *literals = untag_vector(dpop());
|
||||
F_VECTOR *rel = untag_vector(dpop());
|
||||
CELL code_format = to_cell(dpop());
|
||||
F_VECTOR *code = untag_vector(dpop());
|
||||
|
||||
add_compiled_block(code,code_format,rel,literals);
|
||||
}
|
||||
|
||||
void primitive_finalize_compile(void)
|
||||
{
|
||||
flush_icache((void*)last_flush,compiling.here - last_flush);
|
||||
|
||||
while(last_flush < compiling.here)
|
||||
last_flush = relocate_code_next(last_flush);
|
||||
|
||||
last_flush = compiling.here;
|
||||
}
|
||||
|
|
|
|||
14
vm/run.h
14
vm/run.h
|
|
@ -103,21 +103,17 @@ void primitive_die(void);
|
|||
typedef struct
|
||||
{
|
||||
CELL header; /* = COMPILED_HEADER */
|
||||
CELL code_length;
|
||||
CELL reloc_length; /* see relocate.h */
|
||||
CELL code_length; /* # bytes */
|
||||
CELL reloc_length; /* # bytes, see relocate.h */
|
||||
CELL literal_length; /* # bytes, see relocate.h */
|
||||
} F_COMPILED;
|
||||
|
||||
#define COMPILED_HEADER 0x01c3babe
|
||||
|
||||
CELL literal_top;
|
||||
CELL literal_max;
|
||||
|
||||
void init_compiler(CELL size);
|
||||
void primitive_compiled_offset(void);
|
||||
void primitive_set_compiled_offset(void);
|
||||
void primitive_add_literal(void);
|
||||
void collect_literals(void);
|
||||
void primitive_add_compiled_block(void);
|
||||
|
||||
CELL last_flush;
|
||||
|
||||
void primitive_flush_icache(void);
|
||||
void primitive_finalize_compile(void);
|
||||
|
|
|
|||
|
|
@ -461,7 +461,8 @@ void fixup_word(F_WORD* word)
|
|||
{
|
||||
/* If this is a compiled word, relocate the code pointer. Otherwise,
|
||||
reset it based on the primitive number of the word. */
|
||||
if(word->xt >= code_relocation_base
|
||||
if(code_relocation_base != 0
|
||||
&& word->xt >= code_relocation_base
|
||||
&& word->xt < code_relocation_base
|
||||
- compiling.base + compiling.limit)
|
||||
code_fixup(&word->xt);
|
||||
|
|
|
|||
Loading…
Reference in New Issue