diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index c75f69fc74..849f9c3eb0 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -59,7 +59,7 @@ cpu "ppc" = [ "/library/compiler/ppc/generator.factor" ] pull-in -"compile" get cpu "x86" = and [ +"compile" get supported-cpu? and [ init-assembler \ car compile \ = compile diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index c1c59d6619..9ac960d04d 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -4,34 +4,6 @@ IN: compiler USING: assembler inference errors kernel lists math namespaces strings words vectors ; -! To support saving compiled code to disk, generator words -! append relocation instructions to this vector. -SYMBOL: relocation-table - -: rel, ( n -- ) relocation-table get vector-push ; - -: relocating compiled-offset cell - rel, ; - -: rel-primitive ( word rel/abs -- ) - #! If flag is true; relative. - 0 1 ? rel, relocating word-primitive rel, ; - -: rel-dlsym ( name dll rel/abs -- ) - #! If flag is true; relative. - 2 3 ? rel, relocating cons intern-literal rel, ; - -: rel-address ( -- ) - #! Relocate address just compiled. - 4 rel, relocating 0 rel, ; - -: rel-word ( word rel/abs -- ) - #! If flag is true; relative. - over primitive? [ - rel-primitive - ] [ - nip [ rel-address ] unless - ] ifte ; - : generate-node ( [[ op params ]] -- ) #! Generate machine code for a node. unswons dup "generator" word-prop [ diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor index 9bb9045a21..4b086e5509 100644 --- a/library/compiler/ppc/stack.factor +++ b/library/compiler/ppc/stack.factor @@ -36,5 +36,14 @@ USING: compiler errors kernel math memory words ; \ dup [ drop PEEK-DS PUSH-DS ] "generator" set-word-prop \ over [ drop 18 14 -4 LWZ PUSH-DS ] "generator" set-word-prop \ pick [ drop 18 14 -8 LWZ PUSH-DS ] "generator" set-word-prop + +\ swap [ + drop + 18 14 -4 LWZ + 19 14 0 LWZ + 19 14 -4 STW + 18 14 0 STW +] "generator" set-word-prop + \ >r [ drop POP-DS PUSH-CS ] "generator" set-word-prop \ r> [ drop POP-CS PUSH-DS ] "generator" set-word-prop diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor index 87bc10a228..448fe44d44 100644 --- a/library/compiler/x86/generator.factor +++ b/library/compiler/x86/generator.factor @@ -10,26 +10,21 @@ math memory namespaces words ; [ ESI ] EAX MOV ] "generator" set-word-prop -: compile-call-label ( label -- ) - 0 CALL fixup compiled-offset defer-xt ; - -: compile-jump-label ( label -- ) - 0 JMP fixup compiled-offset defer-xt ; +: compile-call-label ( label -- ) 0 CALL fixup t defer-xt ; +: compile-jump-label ( label -- ) 0 JMP fixup t defer-xt ; : compile-call ( word -- ) - dup dup postpone-word compile-call-label t rel-word ; + dup postpone-word compile-call-label ; : compile-target ( word -- ) - compiled-offset 0 compile-cell 0 defer-xt ; + compiled-offset 0 compile-cell f defer-xt ; #call [ compile-call ] "generator" set-word-prop #jump [ - dup dup postpone-word - compile-jump-label - t rel-word + dup postpone-word compile-jump-label ] "generator" set-word-prop #call-label [ @@ -45,34 +40,24 @@ math memory namespaces words ; ! condition is now in EAX EAX f address CMP ! jump w/ address added later - 0 JNE fixup compiled-offset defer-xt ; + 0 JNE fixup t defer-xt ; -#jump-t-label [ - compile-jump-t -] "generator" set-word-prop +#jump-t-label [ compile-jump-t ] "generator" set-word-prop -#jump-t [ - dup compile-jump-t t rel-word -] "generator" set-word-prop +#jump-t [ dup compile-jump-t ] "generator" set-word-prop : compile-jump-f ( word -- ) POP-DS ! condition is now in EAX EAX f address CMP ! jump w/ address added later - 0 JE fixup compiled-offset defer-xt ; + 0 JE fixup t defer-xt ; -#jump-f-label [ - compile-jump-f -] "generator" set-word-prop +#jump-f-label [ compile-jump-f ] "generator" set-word-prop -#jump-f [ - dup compile-jump-f t rel-word -] "generator" set-word-prop +#jump-f [ dup compile-jump-f ] "generator" set-word-prop -#return-to [ - 0 PUSH fixup 0 defer-xt rel-address -] "generator" set-word-prop +#return-to [ 0 PUSH fixup f defer-xt ] "generator" set-word-prop #return [ drop RET ] "generator" set-word-prop @@ -83,7 +68,7 @@ math memory namespaces words ; drop POP-DS EAX 1 SHR - EAX HEX: ffff ADD fixup rel-address + EAX HEX: ffff ADD fixup f rel-address [ EAX ] JMP compile-aligned compiled-offset swap set-compiled-cell ( fixup -- ) @@ -91,12 +76,12 @@ math memory namespaces words ; #target-label [ #! Jump table entries are absolute addresses. - compile-target rel-address + compile-target ] "generator" set-word-prop #target [ #! Jump table entries are absolute addresses. - dup dup postpone-word compile-target f rel-word + dup postpone-word compile-target ] "generator" set-word-prop #c-call [ diff --git a/library/compiler/x86/stack.factor b/library/compiler/x86/stack.factor index f6209ee3ce..3911f17125 100644 --- a/library/compiler/x86/stack.factor +++ b/library/compiler/x86/stack.factor @@ -47,7 +47,7 @@ USING: inference kernel assembler words lists alien memory ; [ ESI ] swap address MOV ; : indirect-literal ( obj -- ) - EAX swap intern-literal unit MOV rel-address ; + EAX swap intern-literal unit MOV f rel-address ; #push-immediate [ ESI 4 ADD diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index 49c337f6a4..662806351d 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -2,7 +2,32 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: compiler USING: assembler errors kernel lists math namespaces strings -words ; +vectors words ; + +! To support saving compiled code to disk, generator words +! append relocation instructions to this vector. +SYMBOL: relocation-table + +: rel, ( n -- ) relocation-table get vector-push ; + +: relocating compiled-offset cell - rel, ; + +: rel-primitive ( word rel/abs -- ) + #! If flag is true; relative. + 0 1 ? rel, relocating word-primitive rel, ; + +: rel-dlsym ( name dll rel/abs -- ) + #! If flag is true; relative. + 2 3 ? rel, relocating cons intern-literal rel, ; + +: rel-address ( rel/abs -- ) + #! Relocate address just compiled. If flag is true, + #! relative, and there is nothing to do. + [ 4 rel, relocating 0 rel, ] unless ; + +: rel-word ( word rel/abs -- ) + #! If flag is true; relative. + over primitive? [ rel-primitive ] [ nip rel-address ] ifte ; ! We use a hashtable "compiled-xts" that maps words to ! xt's that are currently being compiled. The commit-xt's word @@ -43,9 +68,11 @@ SYMBOL: deferred-xts SYMBOL: compile-words -: defer-xt ( word where relative -- ) - #! After word is compiled, put its XT at where, relative. - 3list deferred-xts cons@ ; +: defer-xt ( word where rel/abs -- ) + #! After word is compiled, put its XT at where. If rel/abs + #! is true, this is a relative jump. + 3dup compiled-offset 0 ? 3list deferred-xts cons@ + nip rel-word ; : compiling? ( word -- ? ) #! A word that is compiling or already compiled will not be