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

Big redesign of the compiler/runtime interface

slava 2006-08-08 05:38:32 +00:00
parent be9916c903
commit 251f12448f
27 changed files with 391 additions and 503 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -17,7 +17,6 @@
- instead of decompiling words, add them to a 'recompile' set; compiler - instead of decompiling words, add them to a 'recompile' set; compiler
treats words in the recompile set as if they were not compiled treats words in the recompile set as if they were not compiled
- see if alien calls can be made faster - see if alien calls can be made faster
- faster sequence= for UI
- remove literal table - remove literal table
======================================================================== ========================================================================

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

@ -142,7 +142,6 @@ sequences vectors words ;
"/library/compiler/optimizer/print-dataflow.factor" "/library/compiler/optimizer/print-dataflow.factor"
"/library/compiler/generator/architecture.factor" "/library/compiler/generator/architecture.factor"
"/library/compiler/generator/assembler.factor"
"/library/compiler/generator/templates.factor" "/library/compiler/generator/templates.factor"
"/library/compiler/generator/xt.factor" "/library/compiler/generator/xt.factor"
"/library/compiler/generator/generator.factor" "/library/compiler/generator/generator.factor"
@ -251,7 +250,6 @@ sequences vectors words ;
"/library/compiler/alien/malloc.facts" "/library/compiler/alien/malloc.facts"
"/library/compiler/alien/structs.facts" "/library/compiler/alien/structs.facts"
"/library/compiler/alien/syntax.facts" "/library/compiler/alien/syntax.facts"
"/library/compiler/generator/assembler.facts"
"/library/compiler/inference/inference.facts" "/library/compiler/inference/inference.facts"
"/library/compiler/compiler.facts" "/library/compiler/compiler.facts"
"/library/generic/early-generic.facts" "/library/generic/early-generic.facts"

23
library/bootstrap/image.factor
View File

@ -18,7 +18,7 @@ IN: image
( Constants ) ( Constants )
: image-magic HEX: 0f0e0d0c ; inline : image-magic HEX: 0f0e0d0c ; inline
: image-version 0 ; inline : image-version 2 ; inline
: char bootstrap-cell 2 /i ; inline : char bootstrap-cell 2 /i ; inline
@ -36,7 +36,7 @@ IN: image
: tuple-type 17 ; inline : tuple-type 17 ; inline
: byte-array-type 18 ; inline : byte-array-type 18 ; inline
: base 1024 ; inline : data-base 1024 ; inline
: boot-quot-offset 3 ; inline : boot-quot-offset 3 ; inline
: global-offset 4 ; inline : global-offset 4 ; inline
@ -44,8 +44,10 @@ IN: image
: 0-offset 6 ; inline : 0-offset 6 ; inline
: 1-offset 7 ; inline : 1-offset 7 ; inline
: -1-offset 8 ; inline : -1-offset 8 ; inline
: heap-size-offset 9 ; inline : data-heap-size-offset 9 ; inline
: header-size 10 ; inline : code-heap-size-offset 10 ; inline
: header-size 12 ; inline
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -61,9 +63,6 @@ SYMBOL: architecture
: emit ( cell -- ) image get push ; : emit ( cell -- ) image get push ;
: d>w/w ( d -- w w )
dup HEX: ffffffff bitand swap -32 shift HEX: ffffffff bitand ;
: emit-64 ( cell -- ) : emit-64 ( cell -- )
bootstrap-cell 8 = [ bootstrap-cell 8 = [
emit emit
@ -76,7 +75,7 @@ SYMBOL: architecture
: fixup ( value offset -- ) image get set-nth ; : fixup ( value offset -- ) image get set-nth ;
: here ( -- size ) : 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 ; : here-as ( tag -- pointer ) here swap bitor ;
@ -93,14 +92,16 @@ SYMBOL: architecture
: header ( -- ) : header ( -- )
image-magic emit image-magic emit
image-version 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 ( bootstrap quotation set later ) 0 emit
( global namespace set later ) 0 emit ( global namespace set later ) 0 emit
( pointer to t object ) 0 emit ( pointer to t object ) 0 emit
( pointer to bignum 0 ) 0 emit ( pointer to bignum 0 ) 0 emit
( pointer to bignum 1 ) 0 emit ( pointer to bignum 1 ) 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 ) GENERIC: ' ( obj -- ptr )
#! Write an object to the image. #! Write an object to the image.
@ -309,7 +310,7 @@ M: hashtable ' ( hashtable -- pointer )
boot, boot,
"Performing some word fixups..." print flush "Performing some word fixups..." print flush
fixup-words fixup-words
heap-size heap-size-offset fixup heap-size data-heap-size-offset fixup
"Image length: " write image get length . "Image length: " write image get length .
"Object cache size: " write objects get hash-size . "Object cache size: " write objects get hash-size .
\ word global remove-hash ; \ word global remove-hash ;

7
library/bootstrap/primitives.factor
View File

@ -149,10 +149,7 @@ call
{ "tag" "kernel-internals" } { "tag" "kernel-internals" }
{ "cwd" "io" } { "cwd" "io" }
{ "cd" "io" } { "cd" "io" }
{ "compiled-offset" "assembler" } { "add-compiled-block" "assembler" }
{ "set-compiled-offset" "assembler" }
{ "add-literal" "assembler" }
{ "address" "memory" }
{ "dlopen" "alien" } { "dlopen" "alien" }
{ "dlsym" "alien" } { "dlsym" "alien" }
{ "dlclose" "alien" } { "dlclose" "alien" }
@ -206,7 +203,7 @@ call
{ "end-scan" "memory" } { "end-scan" "memory" }
{ "size" "memory" } { "size" "memory" }
{ "die" "kernel" } { "die" "kernel" }
{ "flush-icache" "assembler" } { "finalize-compile" "assembler" }
{ "fopen" "io-internals" } { "fopen" "io-internals" }
{ "fgetc" "io-internals" } { "fgetc" "io-internals" }
{ "fwrite" "io-internals" } { "fwrite" "io-internals" }

5
library/compiler/compiler.facts
View File

@ -40,3 +40,8 @@ HELP: compile-1 "( quot -- )"
{ $values { "quot" "a quotation" } } { $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } { $description "Compiles and runs a quotation." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ; { $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." } ;

5
library/compiler/generator/architecture.factor
View File

@ -2,6 +2,9 @@ IN: compiler
USING: arrays generic kernel kernel-internals math memory USING: arrays generic kernel kernel-internals math memory
namespaces sequences ; namespaces sequences ;
! Does the assembler emit bytes or cells?
DEFER: code-format ( -- byte# )
! A scratch register for computations ! A scratch register for computations
TUPLE: vreg n ; TUPLE: vreg n ;
@ -130,4 +133,4 @@ M: float-regs inc-reg-class
GENERIC: v>operand GENERIC: v>operand
M: integer v>operand tag-bits shift ; M: integer v>operand tag-bits shift ;
M: vreg v>operand dup vreg-n swap vregs nth ; M: vreg v>operand dup vreg-n swap vregs nth ;
M: f v>operand address ; M: f v>operand drop object-tag ;

36
library/compiler/generator/assembler.factor
View File

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

17
library/compiler/generator/assembler.facts
View File

@ -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." } ;

38
library/compiler/generator/generator.factor
View File

@ -37,38 +37,22 @@ UNION: #terminal
dup #terminal-call? swap node-successor #terminal? or dup #terminal-call? swap node-successor #terminal? or
] all? ; ] all? ;
: generate-code ( word node quot -- length | quot: node -- ) : generate-code ( node quot -- | quot: node -- )
compiled-offset >r over stack-reserve %prologue call ; inline
compile-aligned
rot save-xt
over stack-reserve %prologue
call
compile-aligned
compiled-offset r> - ;
: generate-reloc ( -- length ) : init-generator ( -- )
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
V{ } clone relocation-table set V{ } clone relocation-table set
init-templates begin-assembly swap ; V{ } clone literal-table set ;
: generate-1 ( word node quot -- | quot: node -- ) : generate-1 ( word node quot -- | quot: node -- )
#! If generation fails, reset compiled offset.
[ [
begin-generating >r >r init-generator
init-templates
generate-code generate-code
generate-reloc relocation-table get
r> set-compiled-cell literal-table get
r> set-compiled-cell ] V{ } make
] [ code-format 2swap add-compiled-block swap save-xt ;
previous-offset get set-compiled-offset rethrow
] recover ;
SYMBOL: generate-queue SYMBOL: generate-queue
@ -170,7 +154,7 @@ M: #call-label generate-node ( node -- next )
node-param generate-call ; node-param generate-call ;
! #dispatch ! #dispatch
: target-label ( label -- ) 0 assemble-cell absolute-cell ; : target-label ( label -- ) 0 , rel-absolute-cell rel-word ;
: dispatch-head ( node -- label/node ) : dispatch-head ( node -- label/node )
#! Output the jump table insn and return a list of #! Output the jump table insn and return a list of

144
library/compiler/generator/xt.factor
View File

@ -18,152 +18,58 @@ sequences strings vectors words ;
! hastable. ! hastable.
SYMBOL: compiled-xts SYMBOL: compiled-xts
: save-xt ( word -- ) : save-xt ( xt word -- ) compiled-xts get set-hash ;
compiled-offset swap compiled-xts get set-hash ;
: commit-xts ( -- ) : commit-xts ( -- )
#! We must flush the instruction cache on PowerPC.
flush-icache
compiled-xts get [ swap set-word-xt ] hash-each ; compiled-xts get [ swap set-word-xt ] hash-each ;
: compiled-xt ( word -- xt ) : compiled-xt ( word -- xt )
dup compiled-xts get hash [ ] [ word-xt ] ?if ; dup compiled-xts get hash [ ] [ word-xt ] ?if ;
! deferred-xts is a vector of objects responding to the fixup SYMBOL: literal-table
! generic.
SYMBOL: deferred-xts
: 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 SYMBOL: relocation-table
: rel, ( n -- ) relocation-table get push ; : rel, ( n -- ) relocation-table get push ;
: cell-just-compiled compiled-offset cell - ;
: 4-just-compiled compiled-offset 4 - ;
: rel-absolute-cell 0 ; : rel-absolute-cell 0 ;
: rel-absolute 1 ; : rel-absolute 1 ;
: rel-relative 2 ; : 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 -- ) : rel-type, ( arg class type -- )
#! Write a relocation instruction for the runtime image #! Write a relocation instruction for the runtime image
#! loader. #! loader.
over >r >r >r 16 shift r> 8 shift bitor r> bitor rel, 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 -- ) : rel-dlsym ( name dll class -- )
>r 2array add-literal compiled-base - cell / r> >r 2array add-literal r> 1 rel-type, ;
1 rel-type, ;
: rel-address ( class -- ) : rel-here ( class -- )
#! Relocate address just compiled.
dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ; dup rel-relative = [ drop ] [ 0 swap 2 rel-type, ] if ;
: rel-word ( word class -- ) : rel-word ( word class -- )
over primitive? [ over primitive?
>r word-primitive r> 0 rel-type, [ >r word-primitive r> 0 ] [ >r add-literal r> 5 ] if
] [ rel-type, ;
rel-address drop
] if ;
: rel-cards ( class -- ) 0 swap 3 rel-type, ; : rel-cards ( class -- ) 0 swap 3 rel-type, ;
! This is for fixing up forward references : rel-literal ( literal class -- )
GENERIC: resolve ( fixup -- addr ) >r add-literal r> 4 rel-type, ;
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 ;
! When a word is encountered that has not been previously ! When a word is encountered that has not been previously
! compiled, it is pushed onto this vector. Compilation stops ! compiled, it is pushed onto this vector. Compilation stops
@ -178,16 +84,12 @@ SYMBOL: compile-words
over compile-words get member? or over compile-words get member? or
swap compiled-xts get hash or ; swap compiled-xts get hash or ;
: fixup-xts ( -- )
deferred-xts get [ dup resolve swap fixup ] each ;
: with-compiler ( quot -- ) : with-compiler ( quot -- )
[ [
V{ } clone deferred-xts set
H{ } clone compiled-xts set H{ } clone compiled-xts set
V{ } clone compile-words set V{ } clone compile-words set
call call
fixup-xts finalize-compile
commit-xts commit-xts
] with-scope ; ] with-scope ;

10
library/compiler/inference/known-words.factor
View File

@ -289,13 +289,7 @@ sequences strings vectors words prettyprint ;
\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop \ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop \ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
\ compiled-offset [ [ ] [ integer ] ] "infer-effect" set-word-prop \ add-compiled-block [ [ vector integer vector vector ] [ 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
\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop \ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
\ dlsym [ [ string object ] [ integer ] ] "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 \ 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 \ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop

17
library/compiler/ppc/architecture.factor
View File

@ -4,6 +4,8 @@ IN: compiler
USING: alien assembler generic kernel kernel-internals math USING: alien assembler generic kernel kernel-internals math
memory namespaces sequences words ; memory namespaces sequences words ;
: code-format cell ; inline
! PowerPC register assignments ! PowerPC register assignments
! r3-r10 integer vregs ! r3-r10 integer vregs
! f0-f13 float vregs ! f0-f13 float vregs
@ -32,9 +34,7 @@ M: immediate load-literal ( literal vreg -- )
[ v>operand ] 2apply LOAD ; [ v>operand ] 2apply LOAD ;
M: object load-literal ( literal vreg -- ) M: object load-literal ( literal vreg -- )
v>operand swap v>operand [ 0 LOAD32 rel-absolute-2/2 rel-literal ] keep
add-literal over
LOAD32 rel-2/2 rel-address
dup 0 LWZ ; dup 0 LWZ ;
: stack-increment \ stack-reserve get 32 max stack@ 16 align ; : stack-increment \ stack-reserve get 32 max stack@ 16 align ;
@ -56,7 +56,7 @@ M: object load-literal ( literal vreg -- )
: word-addr ( word -- ) : word-addr ( word -- )
#! Load a word address into r3. #! 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 -- ) : %call ( label -- )
#! Far C call for primitives, near C call for compiled defs. #! 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 ; %epilogue dup postpone-word %jump-label ;
: %jump-t ( label -- ) : %jump-t ( label -- )
0 "flag" operand f address CMPI BNE ; 0 "flag" operand object-tag CMPI BNE ;
: %dispatch ( -- ) : %dispatch ( -- )
"n" operand dup 1 SRAWI "n" operand dup 1 SRAWI
! The value 24 is a magic number. It is the length of the ! The value 24 is a magic number. It is the length of the
! instruction sequence that follows to be generated. ! instruction sequence that follows to be generated.
compiled-offset 24 + "scratch" operand LOAD32 0 "scratch" operand LOAD32 rel-absolute-2/2 rel-here
rel-2/2 rel-address
"n" operand dup "scratch" operand ADD "n" operand dup "scratch" operand ADD
"n" operand dup 0 LWZ "n" operand dup 24 LWZ
"n" operand MTLR "n" operand MTLR
BLR ; BLR ;
: %return ( -- ) %epilogue BLR ; : %return ( -- ) %epilogue BLR ;
: compile-dlsym ( symbol dll register -- ) : 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 -- ) M: int-regs (%peek) ( vreg loc -- )
drop >r v>operand r> loc>operand LWZ ; drop >r v>operand r> loc>operand LWZ ;

13
library/compiler/ppc/assembler.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: assembler 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 ! See the Motorola or IBM documentation for details. The opcode
! names are standard, and the operand order is the same as in ! 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 ! 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 ) : a-form ( d a b c xo rc -- n )
>r 1 shift >r 6 shift >r 11 shift >r 16 shift >r 21 shift >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 ; G: (B) ( dest aa lk -- ) 2 standard-combination ;
M: integer (B) i-form 18 insn ; 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) ; : B 0 0 (B) ; : BL 0 1 (B) ;
GENERIC: BC GENERIC: BC
M: integer BC 0 0 b-form 16 insn ; 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 ; : BLT 12 0 rot BC ; : BGE 4 0 rot BC ;
: BGT 12 1 rot BC ; : BLE 4 1 rot BC ; : BGT 12 1 rot BC ; : BLE 4 1 rot BC ;

5
library/compiler/x86/architecture.factor
View File

@ -90,7 +90,7 @@ M: immediate load-literal ( literal vreg -- )
v>operand swap v>operand MOV ; v>operand swap v>operand MOV ;
: load-indirect ( literal reg -- ) : 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 -- ) M: object load-literal ( literal vreg -- )
v>operand load-indirect ; 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 ! Add to jump table base. We use a temporary register since
! on AMD64 we have to load a 64-bit immediate. On x86, this ! on AMD64 we have to load a 64-bit immediate. On x86, this
! is redundant. ! 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 "n" operand "scratch" operand ADD
! Jump to jump table entry ! Jump to jump table entry
"n" operand [] JMP "n" operand [] JMP

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

@ -1,6 +1,6 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! 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 ; math namespaces parser sequences words ;
IN: assembler IN: assembler
@ -10,6 +10,9 @@ IN: assembler
! In 64-bit mode, { 1234 } is RIP-relative. ! In 64-bit mode, { 1234 } is RIP-relative.
! Beware! ! Beware!
: 4, 4 >le % ; inline
: cell, cell >le % ; inline
#! Extended AMD64 registers (R8-R15) return true. #! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? ) GENERIC: extended? ( op -- ? )
@ -183,9 +186,9 @@ M: indirect displacement indirect-displacement ;
M: register displacement drop f ; M: register displacement drop f ;
: addressing ( reg# indirect -- ) : addressing ( reg# indirect -- )
[ mod-r/m assemble-1 ] keep [ mod-r/m , ] keep
[ sib [ assemble-1 ] when* ] keep [ sib [ , ] when* ] keep
displacement [ assemble-4 ] when* ; displacement [ 4, ] when* ;
( Utilities ) ( Utilities )
UNION: operand register indirect ; UNION: operand register indirect ;
@ -217,10 +220,10 @@ UNION: operand register indirect ;
#! Compile an AMD64 REX prefix. #! Compile an AMD64 REX prefix.
pick pick rex.w? BIN: 01001000 BIN: 01000000 ? pick pick rex.w? BIN: 01001000 BIN: 01000000 ?
swap lhs-prefix swap rhs-prefix swap lhs-prefix swap rhs-prefix
dup BIN: 01000000 = [ drop ] [ assemble-1 ] if ; dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- ) : 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 ; : 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 -- ) : short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of #! Some instructions encode their single operand as part of
#! the opcode. #! 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 -- ) : 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the #! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte. #! '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 -- ) : immediate-1 ( imm dst reg rex.w opcode -- )
1-operand assemble-1 ; 1-operand , ;
: immediate-1/4 ( imm dst reg rex.w opcode -- ) : immediate-1/4 ( imm dst reg rex.w opcode -- )
#! If imm is a byte, compile the opcode and the byte. #! 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 pick byte? [
r> r> BIN: 10 bitor immediate-1 r> r> BIN: 10 bitor immediate-1
] [ ] [
r> r> 1-operand assemble-4 r> r> 1-operand 4,
] if ; ] if ;
: 2-operand ( dst src op -- ) : 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the #! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand. #! destination is a direct register operand.
pick register? [ BIN: 10 bitor swapd ] when pick register? [ BIN: 10 bitor swapd ] when
>r 2dup t prefix r> assemble-1 reg-code swap addressing ; >r 2dup t prefix r> , reg-code swap addressing ;
: from ( addr -- addr )
#! Relative to after next 32-bit immediate.
compiled-offset - 4 - ;
PREDICATE: word callable register? not ; PREDICATE: word callable register? not ;
( Moving stuff ) ( Moving stuff )
GENERIC: PUSH ( op -- ) GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ; M: register PUSH f HEX: 50 short-operand ;
M: integer PUSH HEX: 68 assemble-1 assemble-4 ; M: integer PUSH HEX: 68 , 4, ;
M: callable PUSH 0 PUSH absolute-4 ; M: callable PUSH 0 PUSH rel-absolute rel-word ;
M: operand PUSH BIN: 110 f HEX: ff 1-operand ; M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
GENERIC: POP ( op -- ) GENERIC: POP ( op -- )
@ -275,30 +274,30 @@ M: operand POP BIN: 000 f HEX: 8f 1-operand ;
! MOV where the src is immediate. ! MOV where the src is immediate.
GENERIC: (MOV-I) ( src dst -- ) GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand assemble-cell ; M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand assemble-4 ; M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
GENERIC: MOV ( dst src -- ) GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ; 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 ; M: operand MOV HEX: 89 2-operand ;
( Control flow ) ( Control flow )
GENERIC: JMP ( op -- ) GENERIC: JMP ( op -- )
M: integer JMP HEX: e9 assemble-1 from assemble-4 ; ! M: integer JMP HEX: e9 , from 4, ;
M: callable JMP 0 JMP relative-4 ; M: callable JMP 0 JMP rel-relative rel-word ;
M: operand JMP BIN: 100 t HEX: ff 1-operand ; M: operand JMP BIN: 100 t HEX: ff 1-operand ;
GENERIC: CALL ( op -- ) GENERIC: CALL ( op -- )
M: integer CALL HEX: e8 assemble-1 from assemble-4 ; ! M: integer CALL HEX: e8 , from 4, ;
M: callable CALL 0 CALL relative-4 ; M: callable CALL 0 CALL rel-relative rel-word ;
M: operand CALL BIN: 010 t HEX: ff 1-operand ; M: operand CALL BIN: 010 t HEX: ff 1-operand ;
G: JUMPcc ( addr opcode -- ) 1 standard-combination ; G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
M: integer JUMPcc ( addr opcode -- ) ! M: integer JUMPcc ( addr opcode -- )
swap HEX: 0f assemble-1 swap assemble-1 from assemble-4 ; ! swap HEX: 0f , swap , from assemble-4 ;
M: callable JUMPcc ( addr opcode -- ) 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 ; : JO HEX: 80 JUMPcc ;
: JNO HEX: 81 JUMPcc ; : JNO HEX: 81 JUMPcc ;
@ -317,7 +316,7 @@ M: callable JUMPcc ( addr opcode -- )
: JLE HEX: 8e JUMPcc ; : JLE HEX: 8e JUMPcc ;
: JG HEX: 8f JUMPcc ; : JG HEX: 8f JUMPcc ;
: RET ( -- ) HEX: c3 assemble-1 ; : RET ( -- ) HEX: c3 , ;
( Arithmetic ) ( Arithmetic )
@ -363,8 +362,8 @@ M: operand CMP OCT: 071 2-operand ;
GENERIC: IMUL2 ( dst src -- ) GENERIC: IMUL2 ( dst src -- )
M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ; M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
: CDQ HEX: 99 assemble-1 ; : CDQ HEX: 99 , ;
: CQO HEX: 48 assemble-1 CDQ ; : CQO HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ; : ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
: ROR ( dst n -- ) swap BIN: 001 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 -- ) : 2-operand-sse ( dst src op1 op2 -- )
#! We swap the operands here to make everything consistent #! We swap the operands here to make everything consistent
#! with the integer instructions. #! with the integer instructions.
swap assemble-1 pick register-128? [ swapd ] [ 1 bitor ] if swap , pick register-128? [ swapd ] [ 1 bitor ] if
>r 2dup t prefix HEX: 0f assemble-1 r> >r 2dup t prefix HEX: 0f , r>
assemble-1 reg-code swap addressing ; , reg-code swap addressing ;
: MOVSS ( dest src -- ) HEX: f3 HEX: 10 2-operand-sse ; : MOVSS ( dest src -- ) HEX: f3 HEX: 10 2-operand-sse ;
: MOVSD ( dest src -- ) HEX: f2 HEX: 10 2-operand-sse ; : MOVSD ( dest src -- ) HEX: f2 HEX: 10 2-operand-sse ;

12
library/math/integer.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: math IN: math
USING: errors generic kernel kernel-internals sequences USING: errors generic kernel kernel-internals sequences
sequences-internals ; sequences-internals ;
@ -28,6 +28,14 @@ UNION: integer fixnum bignum ;
: next-power-of-2 ( n -- n ) 2 swap (next-power-of-2) ; : 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 IN: math-internals
: fraction> ( a b -- a/b ) : fraction> ( a b -- a/b )

4
library/test/compiler/optimizer.factor
View File

@ -54,11 +54,11 @@ USE: optimizer
[ t ] [ [ [ 1 ] [ 2 ] ] [ [ 1 ] [ 2 ] if ] kill-set= ] unit-test [ 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 [ 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 [ 3 ] [ literal-kill-test-2 drop ] unit-test

4
library/tools/memory.facts
View File

@ -1,10 +1,6 @@
IN: memory IN: memory
USING: errors help test ; 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 -- )" HELP: gc "( n -- )"
{ $values { "n" "a positive integer" } } { $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 } "." } ; { $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 } "." } ;

9
vm/factor.c
View File

@ -2,8 +2,7 @@
void init_factor(const char* image, void init_factor(const char* image,
CELL ds_size, CELL rs_size, CELL cs_size, CELL ds_size, CELL rs_size, CELL cs_size,
CELL gen_count, CELL young_size, CELL aging_size, CELL gen_count, CELL young_size, CELL aging_size, CELL code_size)
CELL code_size, CELL literal_size)
{ {
init_ffi(); init_ffi();
init_arena(gen_count,young_size,aging_size); init_arena(gen_count,young_size,aging_size);
@ -13,7 +12,7 @@ void init_factor(const char* image,
callframe = F; callframe = F;
callframe_scan = callframe_end = 0; callframe_scan = callframe_end = 0;
thrown_error = F; thrown_error = F;
load_image(image,literal_size); load_image(image);
call(userenv[BOOT_ENV]); call(userenv[BOOT_ENV]);
init_c_io(); init_c_io();
init_signals(); init_signals();
@ -48,7 +47,6 @@ int main(int argc, char** argv)
CELL young_size = 2 * CELLS; CELL young_size = 2 * CELLS;
CELL aging_size = 4 * CELLS; CELL aging_size = 4 * CELLS;
CELL code_size = CELLS; CELL code_size = CELLS;
CELL literal_size = 128;
F_ARRAY *args; F_ARRAY *args;
CELL arg_count; CELL arg_count;
CELL i; CELL i;
@ -83,8 +81,7 @@ int main(int argc, char** argv)
generations, generations,
young_size * 1024 * 1024, young_size * 1024 * 1024,
aging_size * 1024 * 1024, aging_size * 1024 * 1024,
code_size * 1024 * 1024, code_size * 1024 * 1024);
literal_size * 1024);
arg_count = (image_given ? 2 : 1); arg_count = (image_given ? 2 : 1);
args = array(ARRAY_TYPE,argc,F); args = array(ARRAY_TYPE,argc,F);

203
vm/image.c
View File

@ -13,11 +13,10 @@ void init_objects(HEADER *h)
bignum_neg_one = h->bignum_neg_one; bignum_neg_one = h->bignum_neg_one;
} }
void load_image(const char* filename, int literal_table) void load_image(const char* filename)
{ {
FILE* file; FILE* file;
HEADER h; HEADER h;
HEADER_2 ext_h;
file = fopen(filename,"rb"); file = fopen(filename,"rb");
if(file == NULL) if(file == NULL)
@ -29,54 +28,39 @@ void load_image(const char* filename, int literal_table)
printf("Loading %s...",filename); printf("Loading %s...",filename);
/* read header */
{
/* read it in native byte order */ /* read it in native byte order */
fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file); fread(&h,sizeof(HEADER)/sizeof(CELL),sizeof(CELL),file);
if(h.magic != IMAGE_MAGIC) if(h.magic != IMAGE_MAGIC)
fatal_error("Bad magic number",h.magic); fatal_error("Bad magic number",h.magic);
if(h.version == IMAGE_VERSION) 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
fatal_error("Bad version number",h.version); fatal_error("Bad version number",h.version);
}
/* read data heap */ /* read data heap */
{ {
CELL size = h.size / CELLS; CELL size = h.data_size / CELLS;
allot(h.size); allot(h.data_size);
if(size != fread((void*)tenured.base,sizeof(CELL),size,file)) 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; tenured.here = tenured.base + h.data_size;
data_relocation_base = h.relocation_base; data_relocation_base = h.data_relocation_base;
} }
/* read code heap */ /* read code heap */
{ {
CELL size = ext_h.size; CELL size = h.code_size;
if(size + compiling.base >= compiling.limit) 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 if(h.version == IMAGE_VERSION
&& size != fread((void*)compiling.base,1,size,file)) && 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; compiling.here = compiling.base + h.code_size;
literal_top = compiling.base + ext_h.literal_top; code_relocation_base = h.code_relocation_base;
literal_max = compiling.base + ext_h.literal_max;
compiling.here = compiling.base + ext_h.size;
code_relocation_base = ext_h.relocation_base;
} }
fclose(file); fclose(file);
@ -97,7 +81,6 @@ bool save_image(const char* filename)
{ {
FILE* file; FILE* file;
HEADER h; HEADER h;
HEADER_2 ext_h;
fprintf(stderr,"Saving %s...\n",filename); fprintf(stderr,"Saving %s...\n",filename);
@ -107,24 +90,20 @@ bool save_image(const char* filename)
h.magic = IMAGE_MAGIC; h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION; h.version = IMAGE_VERSION;
h.relocation_base = tenured.base; h.data_relocation_base = tenured.base;
h.boot = userenv[BOOT_ENV]; h.boot = userenv[BOOT_ENV];
h.size = tenured.here - tenured.base; h.data_size = tenured.here - tenured.base;
h.global = userenv[GLOBAL_ENV]; h.global = userenv[GLOBAL_ENV];
h.t = T; h.t = T;
h.bignum_zero = bignum_zero; h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one; h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_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); fwrite(&h,sizeof(HEADER),1,file);
ext_h.size = compiling.here - compiling.base; fwrite((void*)tenured.base,h.data_size,1,file);
ext_h.literal_top = literal_top - compiling.base; fwrite((void*)compiling.base,h.code_size,1,file);
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);
fclose(file); fclose(file);
@ -189,13 +168,6 @@ void relocate_data()
allot_barrier(relocating); allot_barrier(relocating);
relocate_object(relocating); relocate_object(relocating);
} }
for(relocating = compiling.base;
relocating < literal_top;
relocating += CELLS)
{
data_fixup((CELL*)relocating);
}
} }
void undefined_symbol(void) void undefined_symbol(void)
@ -203,10 +175,17 @@ void undefined_symbol(void)
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true); 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); 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))); F_STRING *symbol = untag_string(get(AREF(pair,0)));
CELL library = get(AREF(pair,1)); CELL library = get(AREF(pair,1));
DLL *dll = (library == F ? NULL : untag_dll(library)); DLL *dll = (library == F ? NULL : untag_dll(library));
@ -223,99 +202,141 @@ CELL get_rel_symbol(F_REL* rel)
return sym; 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)) switch(REL_TYPE(rel))
{ {
case F_PRIMITIVE: case RT_PRIMITIVE:
return primitive_to_xt(REL_ARGUMENT(rel)); return primitive_to_xt(REL_ARGUMENT(rel));
case F_DLSYM: case RT_DLSYM:
return get_rel_symbol(rel); return get_rel_symbol(rel,literal_start);
case F_ABSOLUTE: case RT_HERE:
return original + (compiling.base - code_relocation_base); return offset;
case F_CARDS: case RT_CARDS:
return cards_offset; 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: default:
critical_error("Unsupported rel type",rel->type); critical_error("Unsupported rel type",rel->type);
return -1; return -1;
} }
} }
INLINE CELL relocate_code_next(CELL relocating) INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start)
{
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)
{ {
CELL original; CELL original;
CELL new_value; CELL new_value;
CELL offset = rel->offset + code_start;
code_fixup(&rel->offset);
switch(REL_CLASS(rel)) switch(REL_CLASS(rel))
{ {
case REL_ABSOLUTE_CELL: case REL_ABSOLUTE_CELL:
original = get(rel->offset); original = get(offset);
break; break;
case REL_ABSOLUTE: case REL_ABSOLUTE:
original = *(u32*)rel->offset; original = *(u32*)offset;
break; break;
case REL_RELATIVE: case REL_RELATIVE:
original = *(u32*)rel->offset - (rel->offset + sizeof(u32)); original = *(u32*)offset - (offset + sizeof(u32));
break; break;
case REL_2_2: case REL_ABSOLUTE_2_2:
original = reloc_get_2_2(rel->offset); 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; break;
default: default:
critical_error("Unsupported rel class",REL_CLASS(rel)); critical_error("Unsupported rel class",REL_CLASS(rel));
return -1; return;
} }
/* to_c_string can fill up the heap */ /* to_c_string can fill up the heap */
maybe_gc(0); maybe_gc(0);
new_value = compute_code_rel(rel,original); new_value = compute_code_rel(rel,original,offset,literal_start);
switch(REL_CLASS(rel)) switch(REL_CLASS(rel))
{ {
case REL_ABSOLUTE_CELL: case REL_ABSOLUTE_CELL:
put(rel->offset,new_value); put(offset,new_value);
break; break;
case REL_ABSOLUTE: case REL_ABSOLUTE:
*(u32*)rel->offset = new_value; *(u32*)offset = new_value;
break; break;
case REL_RELATIVE: case REL_RELATIVE:
*(u32*)rel->offset = new_value - (rel->offset + CELLS); *(u32*)offset = new_value - (offset + sizeof(u32));
break; break;
case REL_2_2: case REL_ABSOLUTE_2_2:
reloc_set_2_2(rel->offset,new_value); 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; break;
default: default:
critical_error("Unsupported rel class",REL_CLASS(rel)); 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() void relocate_code()
{ {
/* start relocating from the end of the space reserved for literals */ /* start relocating from the end of the space reserved for literals */
CELL relocating = literal_max; CELL relocating = compiling.base;
while(relocating < compiling.here) while(relocating < compiling.here)
relocating = relocate_code_next(relocating); relocating = relocate_code_next(relocating);
} }

52
vm/image.h
View File

@ -1,13 +1,12 @@
#define IMAGE_MAGIC 0x0f0e0d0c #define IMAGE_MAGIC 0x0f0e0d0c
#define IMAGE_VERSION_0 0 #define IMAGE_VERSION 2
#define IMAGE_VERSION 1
typedef struct { typedef struct {
CELL magic; CELL magic;
CELL version; CELL version;
/* all pointers in the image file are relocated from /* all pointers in the image file are relocated from
relocation_base to here when the image is loaded */ relocation_base to here when the image is loaded */
CELL relocation_base; CELL data_relocation_base;
/* tagged pointer to bootstrap quotation */ /* tagged pointer to bootstrap quotation */
CELL boot; CELL boot;
/* tagged pointer to global namespace */ /* tagged pointer to global namespace */
@ -21,23 +20,15 @@ typedef struct {
/* tagged pointer to bignum -1 */ /* tagged pointer to bignum -1 */
CELL bignum_neg_one; CELL bignum_neg_one;
/* size of heap */ /* size of heap */
CELL size; CELL data_size;
/* size of code heap */
CELL code_size;
/* code relocation base */
CELL code_relocation_base;
} HEADER; } 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 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); bool save_image(const char* file);
void primitive_save_image(void); void primitive_save_image(void);
@ -52,20 +43,29 @@ INLINE void data_fixup(CELL *cell)
typedef enum { typedef enum {
/* arg is a primitive number */ /* arg is a primitive number */
F_PRIMITIVE, RT_PRIMITIVE,
/* arg is a pointer in the literal table hodling a cons where the /* arg is a literal table index, holding an array pair (symbol/dll) */
car is a symbol string, and the cdr is a dll */ RT_DLSYM,
F_DLSYM, /* store current address here */
/* relocate an address to start of code heap */ RT_HERE,
F_ABSOLUTE,
/* store the offset of the card table from the data heap base */ /* 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; } F_RELTYPE;
#define REL_ABSOLUTE_CELL 0 #define REL_ABSOLUTE_CELL 0
#define REL_ABSOLUTE 1 #define REL_ABSOLUTE 1
#define REL_RELATIVE 2 #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 rel type is built like a cell to avoid endian-specific code in
the compiler */ the compiler */
@ -87,6 +87,8 @@ INLINE void code_fixup(CELL *cell)
} }
void relocate_data(); void relocate_data();
CELL relocate_code_next(CELL relocating);
void relocate_code(); void relocate_code();
/* on PowerPC, return the 32-bit literal being loaded at the code at the /* on PowerPC, return the 32-bit literal being loaded at the code at the

5
vm/memory.c
View File

@ -140,11 +140,6 @@ void primitive_set_integer_slot(void)
put(SLOT(obj,slot),value); put(SLOT(obj,slot),value);
} }
void primitive_address(void)
{
drepl(tag_bignum(s48_cell_to_bignum(dpeek())));
}
void primitive_size(void) void primitive_size(void)
{ {
drepl(tag_fixnum(object_size(dpeek()))); drepl(tag_fixnum(object_size(dpeek())));

1
vm/memory.h
View File

@ -94,7 +94,6 @@ void primitive_slot(void);
void primitive_set_slot(void); void primitive_set_slot(void);
void primitive_integer_slot(void); void primitive_integer_slot(void);
void primitive_set_integer_slot(void); void primitive_set_integer_slot(void);
void primitive_address(void);
void primitive_size(void); void primitive_size(void);
CELL clone(CELL obj); CELL clone(CELL obj);
void primitive_clone(void); void primitive_clone(void);

7
vm/primitives.c
View File

@ -121,10 +121,7 @@ void* primitives[] = {
primitive_tag, primitive_tag,
primitive_cwd, primitive_cwd,
primitive_cd, primitive_cd,
primitive_compiled_offset, primitive_add_compiled_block,
primitive_set_compiled_offset,
primitive_add_literal,
primitive_address,
primitive_dlopen, primitive_dlopen,
primitive_dlsym, primitive_dlsym,
primitive_dlclose, primitive_dlclose,
@ -178,7 +175,7 @@ void* primitives[] = {
primitive_end_scan, primitive_end_scan,
primitive_size, primitive_size,
primitive_die, primitive_die,
primitive_flush_icache, primitive_finalize_compile,
primitive_fopen, primitive_fopen,
primitive_fgetc, primitive_fgetc,
primitive_fwrite, primitive_fwrite,

118
vm/run.c
View File

@ -277,49 +277,95 @@ void type_error(CELL type, CELL tagged)
void init_compiler(CELL size) 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) if(compiling.base == 0)
fatal_error("Cannot allocate code heap",size); fatal_error("Cannot allocate code heap",size);
compiling.limit = compiling.base + size; compiling.limit = compiling.base + size;
last_flush = compiling.base; 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) void collect_literals(void)
{ {
CELL i; /* CELL i;
for(i = compiling.base; i < literal_top; i += CELLS) 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
View File

@ -103,21 +103,17 @@ void primitive_die(void);
typedef struct typedef struct
{ {
CELL header; /* = COMPILED_HEADER */ CELL header; /* = COMPILED_HEADER */
CELL code_length; CELL code_length; /* # bytes */
CELL reloc_length; /* see relocate.h */ CELL reloc_length; /* # bytes, see relocate.h */
CELL literal_length; /* # bytes, see relocate.h */
} F_COMPILED; } F_COMPILED;
#define COMPILED_HEADER 0x01c3babe #define COMPILED_HEADER 0x01c3babe
CELL literal_top;
CELL literal_max;
void init_compiler(CELL size); 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 collect_literals(void);
void primitive_add_compiled_block(void);
CELL last_flush; CELL last_flush;
void primitive_flush_icache(void); void primitive_finalize_compile(void);

3
vm/types.c
View File

@ -461,7 +461,8 @@ void fixup_word(F_WORD* word)
{ {
/* If this is a compiled word, relocate the code pointer. Otherwise, /* If this is a compiled word, relocate the code pointer. Otherwise,
reset it based on the primitive number of the word. */ 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 && word->xt < code_relocation_base
- compiling.base + compiling.limit) - compiling.base + compiling.limit)
code_fixup(&word->xt); code_fixup(&word->xt);