diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index e808d9f21d..1962d06ebc 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -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 ======================================================================== diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index a9f0ee3c5f..f56fe9f229 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -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" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index cd5a568b3f..e1a09e5653 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -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,16 +36,18 @@ 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 -: t-offset 5 ; inline -: 0-offset 6 ; inline -: 1-offset 7 ; inline -: -1-offset 8 ; inline -: heap-size-offset 9 ; inline -: header-size 10 ; inline +: boot-quot-offset 3 ; inline +: global-offset 4 ; inline +: t-offset 5 ; inline +: 0-offset 6 ; inline +: 1-offset 7 ; inline +: -1-offset 8 ; 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 ; diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 78e17f768f..1ada707a84 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -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" } diff --git a/library/compiler/compiler.facts b/library/compiler/compiler.facts index c0df84b241..89b5b5c0b4 100644 --- a/library/compiler/compiler.facts +++ b/library/compiler/compiler.facts @@ -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." } ; diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor index f4cd6d2084..d7cfaf81bd 100644 --- a/library/compiler/generator/architecture.factor +++ b/library/compiler/generator/architecture.factor @@ -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 ; diff --git a/library/compiler/generator/assembler.factor b/library/compiler/generator/assembler.factor deleted file mode 100644 index 4cfa99e9c5..0000000000 --- a/library/compiler/generator/assembler.factor +++ /dev/null @@ -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> ; diff --git a/library/compiler/generator/assembler.facts b/library/compiler/generator/assembler.facts deleted file mode 100644 index fa00507a5e..0000000000 --- a/library/compiler/generator/assembler.facts +++ /dev/null @@ -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." } ; diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor index 830e2f18f3..f608fd6ae2 100644 --- a/library/compiler/generator/generator.factor +++ b/library/compiler/generator/generator.factor @@ -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 - generate-code - generate-reloc - r> set-compiled-cell - r> set-compiled-cell - ] [ - previous-offset get set-compiled-offset rethrow - ] recover ; + init-generator + init-templates + generate-code + 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 diff --git a/library/compiler/generator/xt.factor b/library/compiler/generator/xt.factor index a6209328bd..56ec99efee 100644 --- a/library/compiler/generator/xt.factor +++ b/library/compiler/generator/xt.factor @@ -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 ; - -: ( resolver at -- ) - #! Only for PowerPC branch instructions. - BIN: 11111111111111111111111100 ; - -: ( resolver at -- ) - #! Only for PowerPC conditional branch instructions. - BIN: 1111111111111100 ; - -: or-compiled ( n off -- ) - [ compiled-cell bitor ] keep set-compiled-cell ; - -M: fixup-bitfield fixup ( addr fixup -- ) - [ fixup-bitfield-mask bitand ] keep - fixup-bitfield-at or-compiled ; - -TUPLE: fixup-2/2 at ; - -C: fixup-2/2 ( resolver at -- fixup ) - [ set-fixup-2/2-at ] keep [ set-delegate ] keep ; - -M: fixup-2/2 fixup ( addr fixup -- ) - fixup-2/2-at >r w>h/h r> tuck 4 - or-compiled or-compiled ; - -: relative-4 ( word -- ) - dup rel-relative rel-word - compiled-offset - 4-just-compiled deferred-xt ; - -: relative-3 ( word -- ) - #! Labels only -- no image relocation information saved - 4-just-compiled - 4-just-compiled deferred-xt ; - -: relative-2 ( word -- ) - #! Labels only -- no image relocation information saved - 4-just-compiled - 4-just-compiled deferred-xt ; - -: relative-2/2 ( word -- ) - #! Labels only -- no image relocation information saved - compiled-offset - 4-just-compiled deferred-xt ; - -: absolute-4 ( word -- ) - dup rel-absolute rel-word - 4-just-compiled deferred-xt ; - -: absolute-2/2 ( word -- ) - dup rel-2/2 rel-word - cell-just-compiled deferred-xt ; - -: absolute-cell ( word -- ) - dup rel-absolute-cell rel-word - cell-just-compiled 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 ; diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor index a28058761f..ef7eeb8f17 100644 --- a/library/compiler/inference/known-words.factor +++ b/library/compiler/inference/known-words.factor @@ -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 \ [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor index e2ebbb9dab..83f1c53960 100644 --- a/library/compiler/ppc/architecture.factor +++ b/library/compiler/ppc/architecture.factor @@ -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 ; diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor index 30e5067675..cf673e335b 100644 --- a/library/compiler/ppc/assembler.factor +++ b/library/compiler/ppc/assembler.factor @@ -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 ; diff --git a/library/compiler/x86/architecture.factor b/library/compiler/x86/architecture.factor index 1e1b441ca6..6ab88c976d 100644 --- a/library/compiler/x86/architecture.factor +++ b/library/compiler/x86/architecture.factor @@ -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 diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index cf7486cd43..f943f62f23 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -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 ; diff --git a/library/math/integer.factor b/library/math/integer.factor index e9fc05767e..1dc11e8799 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -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 ) diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 605ca755a0..07b732a0fe 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -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 diff --git a/library/tools/memory.facts b/library/tools/memory.facts index 3ca47aae7c..5554e56ced 100644 --- a/library/tools/memory.facts +++ b/library/tools/memory.facts @@ -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 } "." } ; diff --git a/vm/factor.c b/vm/factor.c index 60b464a3c9..8240123a33 100644 --- a/vm/factor.c +++ b/vm/factor.c @@ -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); diff --git a/vm/image.c b/vm/image.c index 3a97553126..f17d5fb83b 100644 --- a/vm/image.c +++ b/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); + /* 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.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 - fatal_error("Bad version number",h.version); - } + 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) +INLINE void relocate_code_step(F_REL *rel, CELL code_start, CELL literal_start) +{ + CELL original; + CELL new_value; + CELL offset = rel->offset + code_start; + + switch(REL_CLASS(rel)) + { + case REL_ABSOLUTE_CELL: + original = get(offset); + break; + case REL_ABSOLUTE: + original = *(u32*)offset; + break; + case REL_RELATIVE: + original = *(u32*)offset - (offset + sizeof(u32)); + break; + 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; + } + + /* to_c_string can fill up the heap */ + maybe_gc(0); + new_value = compute_code_rel(rel,original,offset,literal_start); + + switch(REL_CLASS(rel)) + { + case REL_ABSOLUTE_CELL: + put(offset,new_value); + break; + case REL_ABSOLUTE: + *(u32*)offset = new_value; + break; + case REL_RELATIVE: + *(u32*)offset = new_value - (offset + sizeof(u32)); + break; + 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; + } +} + +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); + 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) - { - CELL original; - CELL new_value; + relocate_code_step(rel++,code_start,literal_start); + + CELL *scan = (CELL*)literal_start; + CELL *literal_end = (CELL*)(literal_start + compiled->literal_length); - code_fixup(&rel->offset); - - switch(REL_CLASS(rel)) - { - case REL_ABSOLUTE_CELL: - original = get(rel->offset); - break; - case REL_ABSOLUTE: - original = *(u32*)rel->offset; - break; - case REL_RELATIVE: - original = *(u32*)rel->offset - (rel->offset + sizeof(u32)); - break; - case REL_2_2: - original = reloc_get_2_2(rel->offset); - break; - default: - critical_error("Unsupported rel class",REL_CLASS(rel)); - return -1; - } + /* relocate literal table data */ + while(scan < literal_end) + data_fixup(scan++); - /* to_c_string can fill up the heap */ - maybe_gc(0); - new_value = compute_code_rel(rel,original); - - switch(REL_CLASS(rel)) - { - case REL_ABSOLUTE_CELL: - put(rel->offset,new_value); - break; - case REL_ABSOLUTE: - *(u32*)rel->offset = new_value; - break; - case REL_RELATIVE: - *(u32*)rel->offset = new_value - (rel->offset + CELLS); - break; - case REL_2_2: - reloc_set_2_2(rel->offset,new_value); - break; - default: - critical_error("Unsupported rel class",REL_CLASS(rel)); - return -1; - } - - rel++; - } - - return (CELL)rel_end; + 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); } diff --git a/vm/image.h b/vm/image.h index f8afb8ca2f..b30fa69b24 100644 --- a/vm/image.h +++ b/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 diff --git a/vm/memory.c b/vm/memory.c index b7f8271896..f4dd791a08 100644 --- a/vm/memory.c +++ b/vm/memory.c @@ -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()))); diff --git a/vm/memory.h b/vm/memory.h index 0c78be569e..640d47573c 100644 --- a/vm/memory.h +++ b/vm/memory.h @@ -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); diff --git a/vm/primitives.c b/vm/primitives.c index 72399eb218..44b1b0b86c 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -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, diff --git a/vm/run.c b/vm/run.c index 2624424831..96cb3f9378 100644 --- a/vm/run.c +++ b/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; } diff --git a/vm/run.h b/vm/run.h index 0a64b9c821..c9ecfd761d 100644 --- a/vm/run.h +++ b/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); diff --git a/vm/types.c b/vm/types.c index a3766ab912..4c3f55d300 100644 --- a/vm/types.c +++ b/vm/types.c @@ -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);