[openfirmware] [commit] r2719 - cpu/x86 cpu/x86/build forth/kernel forth/lib forth/wrapper
repository service
svn at openfirmware.info
Fri Dec 2 02:05:04 CET 2011
Author: wmb
Date: Fri Dec 2 02:05:04 2011
New Revision: 2719
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2719
Log:
x86 kernel - Added the option of building a dynamically-relocated version. So far it isn't used in any target platform builds, but when the time comes, it will be especially useful for generic versions where you don't know a priori how much memory is available.
Added:
cpu/x86/basefwrel.bth
cpu/x86/builderrel.bth
cpu/x86/kernelrel.bth
cpu/x86/nullrel.fth
- copied, changed from r2718, cpu/x86/savefort.fth
cpu/x86/toolsrel.bth
Modified:
cpu/x86/basefw.bth
cpu/x86/boot.fth
cpu/x86/build/builder.dic
cpu/x86/builder.bth
cpu/x86/kerncode.fth
cpu/x86/kernel.bth
cpu/x86/metainit.fth
cpu/x86/metarel.fth
cpu/x86/objsup.fth
cpu/x86/saveexp.fth
cpu/x86/savefort.fth
cpu/x86/savemeta.fth
cpu/x86/syscall.fth
cpu/x86/target.fth
cpu/x86/tools.bth
forth/kernel/kernel.fth
forth/lib/brackif.fth
forth/wrapper/wrapper.c
Modified: cpu/x86/basefw.bth
==============================================================================
--- cpu/x86/basefw.bth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/basefw.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -129,8 +129,8 @@
tag-file @ fclose tag-file off
-cr .( --- Saving basefw.dic --- ) " basefw.dic" $save-forth cr
-
+\- rel cr .( --- Saving basefw.dic --- ) " basefw.dic" $save-forth cr
+\+ rel cr .( --- Saving basefwrel.dic --- ) " basefwrel.dic" $save-forth cr
[then]
\ LICENSE_BEGIN
Added: cpu/x86/basefwrel.bth
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cpu/x86/basefwrel.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -0,0 +1,8 @@
+\ See license at end of file
+purpose: Load file for Forth toolkit, without firmware
+
+dictionary: ${BP}/cpu/x86/build/toolsrel.dic
+command: &x86forth &dictionary &this
+build-now
+
+fload ${BP}/cpu/x86/basefw.bth
Modified: cpu/x86/boot.fth
==============================================================================
--- cpu/x86/boot.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/boot.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -1,12 +1,8 @@
\ See license at end of file
-\ Version for running Forth under DOS, either under the Phar Lap
-\ DOS Extender or under the Zortech C DOS Extender.
-
-\ Boot code (cold and warm start). The cold start code is executed
+\ Boot code (cold start). The cold start code is executed
\ when Forth is initially started. Its job is to initialize the Forth
-\ virtual machine registers. The warm start code is executed when Forth
-\ is re-entered, perhaps as a result of an exception.
+\ virtual machine registers.
hex
@@ -32,8 +28,10 @@
mlabel cold-code
forth-h
-h# e9 origin-t c!-t \ Relative jump with 32-bit offset
-here-t origin-t 5 + - origin-t 1+ !-t \ Offset relative to instruction end
+\- rel-t h# e9 origin-t c!-t \ Relative jump with 32-bit offset
+\- rel-t here-t origin-t 5 + - origin-t 1+ !-t \ Offset relative to instruction end
+\+ rel-t h# e9 jmp-header c! \ Relative jump with 32-bit offset
+\+ rel-t here-t /jmp-header + 5 - jmp-header 1+ le-l! \ Offset relative to instruction end
assembler
\ The segment registers are set correctly, and the stack pointer is
@@ -41,11 +39,15 @@
\ Get the origin address
here-t 5 + #) call here-t origin-t - ( offset )
- bx pop
- ( offset ) # bx sub \ Origin in bx
+\- rel-t bx pop
+\- rel-t ( offset ) # bx sub \ Origin in bx
+
+\+ rel-t up pop
+\+ rel-t ( offset ) # up sub \ Origin in up
- 20 [bx] di lea
- di 'user up0 mov \ initialize up0 (needed for future relocation)
+\- rel-t 20 [bx] up lea
+\- rel-t up 'user up0 mov \ initialize up0 (needed for future relocation)
+\+ rel-t up 'user up0 mov \ initialize up0 (needed for future relocation)
\ Set the value of flat? so later code can determine whether or
\ not it is safe to do things like setting the stack segment descriptor,
@@ -66,33 +68,37 @@
sp ax mov
[ifdef] notdef
-\ this version is ROMable
+\ this version is ROMable - and is incompatible with relative addressing
\ Allocate the RAM copy of the User Area
user-size-t # sp sub
\ Copy the initial User Area image to the RAM copy
- userarea-t [bx] si lea \ Source address for copy
+ rel-t userarea-t [bx] si lea \ Source address for copy
sp di mov \ Destination of copy
user-size-t # cx mov \ Number of bytes to copy
cld rep byte movs
- sp di mov \ Set user pointer
+ sp up mov \ Set user pointer
[else]
- userarea-t [bx] di lea \ Source address for copy
+\- rel-t userarea-t [bx] up lea \ User pointer
+\+ rel-t userarea-t [up] up lea \ User pointer
[then]
\ XXX need to swap bytes
\ Set main-task so the exception handler can find the user area
- di 'body main-task [bx] mov
+\- rel-t up 'body main-task [bx] mov
+\+ rel-t up 'body main-task [up] mov
?bswap-ax
ax 'user memtop mov \ Set heap pointer
- h# 10 [bx] ax mov \ #args
+\- rel-t h# 10 [bx] ax mov \ #args
+\+ rel-t h# -10 [up] ax mov \ #args
?bswap-ax
ax 'user #args mov
- h# 14 [bx] ax mov \ args
+\- rel-t h# 14 [bx] ax mov \ args
+\+ rel-t h# -c [up] ax mov \ args
?bswap-ax
ax 'user args mov
@@ -123,62 +129,22 @@
ps-size-t # ax sub \ allocate space for the data stack
ax 'user limit mov \ Set dictionary limit
+\+ rel-t 'user dp ax mov
+\+ rel-t up ax add
+\+ rel-t ax 'user dp mov
+
\ Enter Forth
- 'body cold [bx] ip lea
+\- rel-t 'body cold [bx] ip lea
+\+ rel-t 'body cold [up] ip lea
c;
-create ztc-startup ( -- ) assembler
-
-\ This is for the Zortech C DOS Extender version which extracts the starting
-\ address from location c and jumps directly to it.
-
-forth-h
-\ here-t origin-t h# c + le-l!-t \ Address of ztc-startup relative to origin
-here-t h# 0c token!-t \ Address of ztc-startup relative to origin
-assembler
-
-\ The stack contains:
-\ ( Data selector [4 bytes], memory size [4 bytes], return-address [6 bytes] )
-
- bp push
- sp bp mov
- si push
- di push
- 8 [bp] dx mov \ DX - caller's CS
-
- ds si mov \ SI - caller's DS
- ss di mov \ DI - caller's SS
- sp cx mov \ CX - caller's SP
-
- 0c [bp] ax mov \ Memory top
- 10 [bp] ds mov
- ds bx mov
-
- bx ss mov \ Get onto new stack
- ax sp mov
-
- \ GS FS ES DS CS SS SP
- gs push fs push es push si push dx push di push cx push
-
-
- dx h# a #) op: mov \ Fix selector of far pointer at origin + 6
- \ Zortech C appears to store it incorrectly
- \ memtop @ 8 + le-l@ h# a le-w!
-
- bx es mov
- bx fs mov
- bx gs mov
-
- cold-code #) jmp \ Proceed with the usual startup
-end-code
-
create unix-startup ( -- ) assembler
\ This is the entry point for the Unix wrapper
forth-h
-\ here-t origin-t h# 18 + le-l!-t \ Address of unix-startup relative to origin
-here-t h# 18 token!-t \ Address of unix-startup relative to origin
+\- rel-t here-t h# 18 token!-t \ Address of unix-startup
+\+ rel-t here-t /jmp-header + jmp-header h# 18 + le-l! \ Address of unix-startup
assembler
\ The stack contains:
@@ -203,28 +169,10 @@
cold-code #) jmp \ Proceed with the usual startup
end-code
-create warm-code ( -- ) assembler
-\ Set the base address
-\ here-t 4 + call \ address of next instruction in spc
-\ here-t 4 - base set \ relative address of current instruction
-\ spc base base sub \ subtract them to find the base address
-\
-\ \ Set the User Pointer
-\ 'body main-task up set \ relative address of main-task parameter field
-\ up base up add \ absolute address of main-task parameter field
-\ up up get \ read the value
-\
-\ 'user sp0 sp ld \ Establish the Parameter Stack
-\ 'user rp0 rp ld \ Establish the Return Stack
-\ 'body warm ip set \ Set IP to execute warm
-\ ip base ip add
-
-next
meta
decimal
-\ : install-warm ( -- ) warm-code origin put-branch ;
\ : install-cold ( -- ) cold-code origin put-branch ;
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
Modified: cpu/x86/build/builder.dic
==============================================================================
Binary file (source and/or target). No diff available.
Modified: cpu/x86/builder.bth
==============================================================================
--- cpu/x86/builder.bth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/builder.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -7,4 +7,5 @@
fload ${BP}/ofw/tokenizer/tokenize.fth \ Tokenizer
fload ${BP}/forth/lib/builder.fth \ Builder
-.( --- Saving builder.dic --- ) " builder.dic" $save-forth cr
+\- rel .( --- Saving builder.dic --- ) " builder.dic" $save-forth cr
+\+ rel .( --- Saving builderrel.dic --- ) " builderrel.dic" $save-forth cr
Added: cpu/x86/builderrel.bth
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cpu/x86/builderrel.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -0,0 +1,7 @@
+purpose: Load file for i386 builder
+
+dictionary: ${BP}/cpu/x86/build/toolsrel.dic
+command: &x86forth &dictionary &this
+build-now
+
+fload ${BP}/cpu/x86/builder.bth
Modified: cpu/x86/kerncode.fth
==============================================================================
--- cpu/x86/kerncode.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/kerncode.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -41,7 +41,11 @@
[ifdef] omit-files
\ assembler macro to assemble next
:-h next
- meta-asm[ ax lods 0 [ax] jmp ]meta-asm
+ meta-asm[
+ ax lods
+\+ rel-t up ax add 0 [ax] bx mov up bx add bx jmp
+\- rel-t 0 [w] jmp
+ ]meta-asm
;-h
[else]
\ assembler macro to assemble next
@@ -84,7 +88,10 @@
here-t
mlabel >next assembler
userarea-t dp-t !
- ax lods 0 [ax] jmp
+ ax lods
+
+\+ rel-t up ax add 0 [ax] bx mov up bx add bx jmp
+\- rel-t 0 [w] jmp
nop nop nop nop nop
end-code
dp-t !
@@ -116,11 +123,15 @@
c;
code-field: dovalue
- [apf] ax mov ?bswap-ax up ax add 0 [ax] ax mov ?bswap-ax 1push
+ [apf] ax mov ?bswap-ax up ax add 0 [ax] ax mov ?bswap-ax
+ 1push
c;
code-field: dodefer
- [apf] ax mov ?bswap-ax up ax add 0 [ax] w mov 0 [w] jmp
+ [apf] ax mov ?bswap-ax up ax add 0 [ax] w mov
+\ Tail of "next"
+\+ rel-t up ax add 0 [ax] bx mov up bx add bx jmp
+\- rel-t 0 [w] jmp
end-code
code-field: doconstant
@@ -160,17 +171,23 @@
\ ---- Run-time words compiled by compiling words.
-
code isdefer ( xt -- )
- 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
+ 0 [ip] ax mov ip ainc
+\+ rel-t up ax add
+ /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
[ifdef] big-endian-t
ax bx mov ax pop ?bswap-ax ax 0 [bx] mov
[else]
- bx pop bx 0 [ax] mov
+ bx pop
+\+ rel-t up bx sub
+ bx 0 [ax] mov
[then]
c;
+
code isvalue ( n -- )
- 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
+ 0 [ip] ax mov ip ainc
+\+ rel-t up ax add
+ /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
[ifdef] big-endian-t
ax bx mov ax pop ?bswap-ax ax 0 [bx] mov
[else]
@@ -178,7 +195,9 @@
[then]
c;
code isuser ( n -- )
- 0 [ip] ax mov ip ainc /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
+ 0 [ip] ax mov ip ainc
+\+ rel-t up ax add
+ /cf [ax] ax mov ?bswap-ax up ax add \ data address in ax
[ifdef] big-endian-t
ax bx mov ax pop ?bswap-ax ax 0 [bx] mov
[else]
@@ -187,11 +206,15 @@
c;
code isconstant ( n -- )
0 [ip] bx mov ip ainc
- ax pop ?bswap-ax ax /cf [bx] mov
+ ax pop ?bswap-ax
+\+ rel-t up bx add
+ ax /cf [bx] mov
c;
code isvariable ( n -- )
0 [ip] bx mov ip ainc
- ax pop ?bswap-ax ax /cf [bx] mov
+ ax pop ?bswap-ax
+\+ rel-t up bx add
+ ax /cf [bx] mov
c;
code bswap (s n1 -- n2 )
@@ -220,7 +243,12 @@
[then]
\ Execute a Forth word given a code field address
-code execute (s acf -- ) w pop 0 [w] jmp end-code
+code execute (s acf -- )
+ w pop
+\ Partial tail of "next"
+\+ rel-t 0 [ax] bx mov up bx add bx jmp
+\- rel-t 0 [w] jmp
+end-code
\ execute-ip This word will call a block of Forth words given the address
\ of the first word. It's used, for example, in try blocks where the
@@ -743,7 +771,11 @@
ax pop ax pop ax pop ax pop ax pop
c;
-code (') (s -- acf ) ax lods 1push c;
+code (') (s -- acf )
+ ax lods
+\+ rel-t up ax add
+ 1push
+c;
\ Modifies caller's ip to skip over an in-line string
code skipstr (s -- addr len)
@@ -886,20 +918,32 @@
\ >target depends on the way that branches are compiled
: >target ( ip-of-branch-instruction -- target ) ta1+ dup branch@ + ;
+\+ rel-t create rel
+
headerless
/a constant /a
-code a@ ( adr1 -- adr2 ) bx pop 0 [bx] push c;
+code a@ (s addr -- cfa )
+ ax pop
+\+ rel-t 0 [ax] ax mov up ax add ax push
+\- rel-t 0 [ax] push
+c;
\ [ifdef] big-endian-t
-: a! ( adr1 adr2 -- ) set-relocation-bit le-! ;
+\+ rel-t code a! ( xt adr -- ) bx pop ax pop up ax sub ax 0 [bx] mov c;
+\- rel-t : a! ( adr1 adr2 -- ) set-relocation-bit le-! ;
\ [else]
\ code a! ( adr1 adr2 -- ) bx pop 0 [bx] pop c;
\ [then]
: a, ( adr -- ) here /a allot a! ;
/token constant /token
-code token@ (s addr -- cfa ) bx pop 0 [bx] push c;
+code token@ (s addr -- cfa )
+ ax pop
+\+ rel-t 0 [ax] ax mov up ax add ax push
+\- rel-t 0 [ax] push
+c;
\ [ifdef] big-endian-t
-: token! ( adr1 adr2 -- ) set-relocation-bit le-! ;
+\+ rel-t code token! ( xt adr -- ) bx pop ax pop up ax sub ax 0 [bx] mov c;
+\- rel-t : token! ( adr1 adr2 -- ) set-relocation-bit le-! ;
\ [else]
\ code token! (s cfa addr -- ) bx pop 0 [bx] pop c;
\ [then]
@@ -916,9 +960,9 @@
: another-link? ( adr -- false | link true ) link@ non-null? ;
-origin-t constant origin
- /n negate allot-t origin-t token,-t ( make origin relocatable )
-
+\+ rel-t code origin (s -- addr ) up push c;
+\- rel-t origin-t constant origin
+\- rel-t /n negate allot-t origin-t token,-t ( make origin relocatable )
\ The "word type" is a number which distinguishes one type of word
\ from another. This is highly implementation-dependent.
@@ -1098,10 +1142,12 @@
di push \ Save UP
cx cx xor \ Clear high bytes
- here-t 5 + #) call \ Figure out the origin address
- here-t
- bp pop
- origin-t - # bp sub
+\+ rel-t up bp mov \ up (==di) is the origin, but we need to use di for string compare
+
+\- rel-t here-t 5 + #) call \ Figure out the origin address
+\- rel-t here-t
+\- rel-t bp pop
+\- rel-t origin-t - # bp sub
ahead
begin
@@ -1136,7 +1182,8 @@
but then
\ The names did not match, so check the next name in the list
0 [ax] ax mov \ Fetch next link
- ax bp cmp \ Test for end of list
+\+ rel-t bp ax add
+ ax bp cmp \ Test for end of list
0= until
\ If we get here, we've checked all the names with no luck
Modified: cpu/x86/kernel.bth
==============================================================================
--- cpu/x86/kernel.bth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/kernel.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -4,6 +4,16 @@
command: &builder &this
build-now
+: defined? ( "name" -- flag )
+ safe-parse-word $find dup if nip else nip nip then
+;
+: \+ ( "name" "rest of line" -- )
+ defined? 0= if [compile] \ then
+; immediate
+: \- ( "name" "rest of line" -- )
+ defined? if [compile] \ then
+; immediate
+
\ [ifdef] use-postfix-assembler
\ use-postfix-assembler
\ ' 386-assembler >link fence a!
@@ -23,16 +33,16 @@
[ifdef] big-endian-t
create dic-file-name ," kernelbe.dic"
[else]
-create dic-file-name ," kernel.dic"
+\- rel-t create dic-file-name ," kernel.dic"
+\+ rel-t create dic-file-name ," kernelrel.dic"
[then]
[then]
: \Tags [compile] \ ; immediate
: \NotTags ; immediate
-
-\ ' $report-name is include-hook ' noop is include-exit-hook
' noop is include-hook ' noop is include-exit-hook
+\ ' $report-name is include-hook ' noop is include-exit-hook
warning off \ Turn OFF the warning messages
@@ -45,6 +55,11 @@
: resident ;
+\ : \rel-t ( -- ) [compile] \ ; immediate
+\ : \!rel-t ( -- ) ; immediate
+\ : \rel-t ( -- ) ; immediate
+\ : \!rel-t ( -- ) [compile] \ ; immediate
+
fload ${BP}/forth/kernel/conft32.fth
fload ${BP}/forth/kernel/meta1.fth
@@ -64,14 +79,7 @@
fload ${BP}/cpu/x86/fixvoc.fth
fload ${BP}/forth/kernel/metacompile.fth
-fload ${BP}/cpu/x86/metarel.fth
-
-only forth meta also forth also definitions
-defer relocation-map
-' relocation-map-t is relocation-map
-' meta-set-relocation-bit is set-relocation-bit-t
-' meta-init-relocation is init-relocation-t
-only forth also definitions
+\- rel-t fload ${BP}/cpu/x86/metarel.fth
fload ${BP}/cpu/x86/metainit.fth
@@ -99,12 +107,11 @@
fload ${BP}/forth/lib/bitops.fth
[ifdef] omit-files
-defer set-relocation-bit
-defer clear-relocation-bits
-' noop is set-relocation-bit
-' 2drop is clear-relocation-bits
+defer set-relocation-bit ' noop is set-relocation-bit
+defer clear-relocation-bits ' 2drop is clear-relocation-bits
[else]
-fload ${BP}/cpu/x86/kernrel.fth
+\- rel-t fload ${BP}/cpu/x86/kernrel.fth
+\+ rel-t fload ${BP}/cpu/x86/nullrel.fth
[then]
fload ${BP}/forth/lib/struct.fth
Added: cpu/x86/kernelrel.bth
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cpu/x86/kernelrel.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -0,0 +1,8 @@
+purpose: Load file for x86 Forth kernel
+\ See license at end of file
+
+command: &builder &this
+build-now
+
+create rel-t
+fload ${BP}/cpu/x86/kernel.bth
Modified: cpu/x86/metainit.fth
==============================================================================
--- cpu/x86/metainit.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/metainit.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -8,6 +8,10 @@
warning off
forth definitions
+\+ rel-t \ This is prepended to the dictionary image
+\+ rel-t h# 20 constant /jmp-header
+\+ rel-t /jmp-header buffer: jmp-header
+
metaon
meta definitions
@@ -23,7 +27,7 @@
\ This number is a target token rather than an absolute address.
hex
-0.0000 org 0.0000
+ 0 org 0
voc-link-t token-t!
ps-size-t equ ps-size
@@ -41,30 +45,30 @@
hex
mlabel cld
-\ boot.fth will store a jmp instruction to cold-code at this location,
-\ so that the PharLap DOS extender may execute the Forth image directly
-\ by jumping to its beginning address.
-( offset 0 ) 0 c,-t 0 l,-t
-
-\ This byte is unused
-( offset 5 ) 0 c,-t
-
-\ The Zortech loader will put a far pointer to EMACS at location 6
-( offset 6 ) 0 l,-t 0 w,-t
-
-\ boot.fth will store the address of cold-code at this location.
-\ The Zortech-based protected-mode loader reads this location to find the
-\ place to begin execution. Zortech's null-pointer detection prevents
-\ the use of location zero.
-( offset c ) 0 l,-t
-
-\ These location are used for the argc and argv values for the Zortech loader
-
-( offset 10 ) 0 l,-t \ argc (set by Zortech loader, read by cold-code)
-( offset 14 ) 0 l,-t \ argv (set by Zortech loader, read by cold-code)
+\- rel-t \ boot.fth will store a jmp instruction to cold-code at this location,
+\- rel-t \ so that the Forth image can be executed by jumping to its beginning address.
+\- rel-t ( offset 0 ) 0 c,-t 0 l,-t
+\- rel-t
+\- rel-t \ This byte is unused
+\- rel-t ( offset 5 ) 0 c,-t
+\- rel-t
+\- rel-t \ (Historical) The Zortech loader will put a far pointer to EMACS at location 6
+\- rel-t ( offset 6 ) 0 l,-t 0 w,-t
+\- rel-t
+\- rel-t \ boot.fth will store the address of cold-code at this location.
+\- rel-t \ The Zortech-based protected-mode loader reads this location to find the
+\- rel-t \ place to begin execution. Zortech's null-pointer detection prevents
+\- rel-t \ the use of location zero.
+\- rel-t ( offset c ) 0 l,-t
+\- rel-t
+\- rel-t \ These locations are used for the argc and argv values for the Zortech loader
+\- rel-t
+\- rel-t ( offset 10 ) 0 l,-t \ argc (set by Zortech loader, read by cold-code)
+\- rel-t ( offset 14 ) 0 l,-t \ argv (set by Zortech loader, read by cold-code)
+\- rel-t
+\- rel-t ( offset 18 ) 0 l,-t \ Address of entry point for executing from the wrapper
+\- rel-t ( offset 1c ) 0 l,-t \ Base address where last saved, or -1 for position-independent
-( offset 18 ) 0 l,-t \ padding
-( offset 1c ) 0 l,-t \ padding
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: cpu/x86/metarel.fth
==============================================================================
--- cpu/x86/metarel.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/metarel.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -28,6 +28,12 @@
:-h meta-init-relocation ( -- )
relocation-map-t /relocation-map-t 0 fill
;
+
+only forth meta also forth also definitions
+' meta-set-relocation-bit is set-relocation-bit-t
+' meta-init-relocation is init-relocation-t
+only forth also definitions
+
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Copied and modified: cpu/x86/nullrel.fth (from r2718, cpu/x86/savefort.fth)
==============================================================================
--- cpu/x86/savefort.fth Fri Dec 2 02:04:52 2011 (r2718, copy source)
+++ cpu/x86/nullrel.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -1,25 +1,17 @@
\ See license at end of file
-hex
+purpose: Null version of relocation table management
-only forth also definitions
+defer set-relocation-bit ' noop is set-relocation-bit
+defer clear-relocation-bits ' 2drop is clear-relocation-bits
-: $save-forth ( name$ -- )
- " sys-init-io" $find-name is init-io ( name$ )
- " sys-init" init-save
- ['] noop is set-relocation-bit \ Turn off until relo map is allocated
+: max-image ( -- #bytes ) memtop @ origin - ;
- origin h# 10 + 8 erase \ Clear #args,args argument locations
- origin origin h# 1c + le-l! \ Set relocation base address
-
- \ Set user initialization table
- up@ init-user-area origin + user-size move ( name$ )
-
- origin here over - $save-image
-;
-only forth also definitions
+: relocation-on ( -- ) ;
+: init-relocation ( -- ) ;
+: relocation-off ( -- ) ;
\ LICENSE_BEGIN
-\ Copyright (c) 2006 FirmWorks
+\ Copyright (c) 2011 FirmWorks
\
\ Permission is hereby granted, free of charge, to any person obtaining
\ a copy of this software and associated documentation files (the
Modified: cpu/x86/objsup.fth
==============================================================================
--- cpu/x86/objsup.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/objsup.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -26,6 +26,7 @@
cx pop \ action# in cx
ax pop \ object-acf in ax
0 [ax] bx mov \ code address in bx
+\+ rel up bx add
-4 [bx] cx cmp \ Test action number
> if \ "true" branch is error
cx push \ Push action#
@@ -37,7 +38,8 @@
4 # ax add \ Push object-apf
ax push
cx neg \ Index backwards into action table
- -4 [bx] [cx] *4 push \ Push action-adr
+\- rel -4 [bx] [cx] *4 push \ Push action-adr
+\+ rel -4 [bx] [cx] *4 ax mov up ax add ax push \ Push action-adr
ax ax xor \ Return false for no error
1push
c;
@@ -48,15 +50,19 @@
4 [ax] cx mov \ Action# in cx
ax lods \ Object acf in ax
+\+ rel up ax add
4 # ax add \ Compute pfa
ax push \ and push it
-4 [ax] ax mov \ Token of default action
+\+ rel up ax add
cx neg \ Index backwards into action table
-4 [ax] [cx] *4 ax mov \ Address of action code
+\+ rel up ax add
- 0 [ax] jmp \ Tail of "NEXT"
+\- rel 0 [ax] jmp \ Tail of "NEXT"
+\+ rel 0 [ax] bx mov up bx add bx jmp \ Tail of "NEXT"
end-code
: >action# ( apf -- action# ) @ ;
Modified: cpu/x86/saveexp.fth
==============================================================================
--- cpu/x86/saveexp.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/saveexp.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -55,11 +55,24 @@
$new-file
exp-header /exp-header ofd @ fputs
+
+\ The dictionary pointer is kept in absolute form at runtime, but must
+\ be stored in relative form in the image file for the relative version.
+\ The absolute version relocates it via the bitmap. The relative version
+\ relocates it with explicit code in cold-code.
+\+ rel-t dp @ origin - dp !
+\+ rel dp @ origin - dp !
code-adr code-size ofd @ fputs
+\+ rel dp @ origin + dp !
+\+ rel-t dp @ origin + dp !
+
+[ifdef] relocation-map
relocation-map code-size h# 0f + 4 >> ofd @ fputs
+[then]
ofd @ fclose
;
+
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: cpu/x86/savefort.fth
==============================================================================
--- cpu/x86/savefort.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/savefort.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -14,7 +14,9 @@
\ Set user initialization table
up@ init-user-area origin + user-size move ( name$ )
- origin here over - $save-image
+ origin
+\+ rel h# 20 -
+ here over - $save-image
;
only forth also definitions
Modified: cpu/x86/savemeta.fth
==============================================================================
--- cpu/x86/savemeta.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/savemeta.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -3,15 +3,16 @@
hex
only forth also meta also forth-h definitions
-: reloc-size ( -- n )
- here-t origin-t - ( user-size-t + )
- 0f + 4 >>
-;
+\- rel-t : reloc-size ( -- n )
+\- rel-t here-t origin-t - ( user-size-t + )
+\- rel-t 0f + 4 >>
+\- rel-t ;
: $save-meta ( filename$ -- )
\ origin-t >hostaddr here-t origin-t - save-image
- origin-t origin-t h# 1c + le-l!-t \ Relocation base of saved image
+\- rel-t origin-t origin-t h# 1c + le-l!-t \ Relocation base of sav
+\+ rel-t -1 jmp-header h# 1c + le-l! \ Relocation base of saved image
here-t origin-t - is code-size
origin-t >hostaddr is code-adr
@@ -19,8 +20,9 @@
$new-file
exp-header /exp-header ofd @ fputs
+\+ rel-t jmp-header /jmp-header ofd @ fputs
code-adr code-size ofd @ fputs
- relocation-map-t reloc-size ofd @ fputs
+\- rel-t relocation-map-t reloc-size ofd @ fputs
ofd @ fclose
;
Modified: cpu/x86/syscall.fth
==============================================================================
--- cpu/x86/syscall.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/syscall.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -48,9 +48,11 @@
18 [bx] gs mov \ his GS
0c [bx] ds mov \ his DS
- here-t 5 + #) call here-t origin-t - ( offset )
- dx pop
- ( offset ) # dx sub
+\+ rel-t h# -20 [up] dx lea
+
+\- rel-t here-t 5 + #) call here-t origin-t - ( offset )
+\- rel-t dx pop
+\- rel-t ( offset ) # dx sub
1 # 'user flat? test 0<> if
6 [dx] call \ cs = 0, forth was called from windows or unix
@@ -84,10 +86,7 @@
defer wrapper-vectors ' noop is wrapper-vectors
defer forth-vectors ' noop is forth-vectors
-: wrapper? ( -- flag ) origin 6 + le-l@ 0<> ;
: wrapper-call ( arg call# -- )
- wrapper? 0= abort" Wrapper calls are not available"
-
wrapper-vectors
memtop @ (wrapper-call)
forth-vectors
Modified: cpu/x86/target.fth
==============================================================================
--- cpu/x86/target.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/target.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -3,8 +3,8 @@
only forth also definitions
-defer init-relocation-t
-defer set-relocation-bit-t
+defer init-relocation-t ' noop is init-relocation-t
+defer set-relocation-bit-t ' noop is set-relocation-bit-t
decimal
@@ -114,14 +114,17 @@
le-l at -t
[else]
\t32-t l at -t
+\+ rel-t origin-t +
[then]
;
: a!-t ( token target-address -- )
set-relocation-bit-t
\t16-t swap origin-t - tshift-t >> swap w!-t
+\+ rel-t origin-t -
[ifdef] big-endian-t
le-l!-t
[else]
+\+ rel-t swap origin-t - swap
\t32-t l!-t
[then]
;
@@ -154,6 +157,7 @@
le@
[else]
\t32-t l-t@
+\+ rel-t origin-t +
[then]
;
: a-t! ( target-address host-address -- )
@@ -161,6 +165,7 @@
[ifdef] big-endian-t
le!
[else]
+\+ rel-t swap origin-t - swap
\t32-t l-t!
[then]
;
@@ -170,6 +175,7 @@
le@
[else]
\t32-t l-t@
+\+ rel-t origin-t +
[then]
;
: rlink-t! ( target-adr host-adr -- )
@@ -177,6 +183,7 @@
[ifdef] big-endian-t
le!
[else]
+\+ rel-t origin-t -
\t32-t l-t!
[then]
;
@@ -252,6 +259,7 @@
#align-t constant #acf-align-t
\t16-t 1 tshift-t << constant #linkalign-t
+\+ rel-t 1 constant #linkalign-t
\t32-t 1 constant #linkalign-t
: aligned-t ( n1 -- n2 ) #align-t 1- + #align-t negate and ;
: acf-aligned-t ( n1 -- n2 ) #acf-align-t 1- + #acf-align-t negate and ;
Modified: cpu/x86/tools.bth
==============================================================================
--- cpu/x86/tools.bth Fri Dec 2 02:04:52 2011 (r2718)
+++ cpu/x86/tools.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -42,8 +42,8 @@
tag-file @ fclose tag-file off
' noop is include-hook ' noop is include-exit-hook
-.( --- Saving tools.dic --- ) " tools.dic" $save-forth cr
-
+\- rel .( --- Saving tools.dic --- ) " tools.dic" $save-forth cr
+\+ rel .( --- Saving toolsrel.dic --- ) " toolsrel.dic" $save-forth cr
[then]
\ LICENSE_BEGIN
Added: cpu/x86/toolsrel.bth
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cpu/x86/toolsrel.bth Fri Dec 2 02:05:04 2011 (r2719)
@@ -0,0 +1,8 @@
+\ See license at end of file
+purpose: Load file for Forth toolkit, without firmware
+
+dictionary: ${BP}/cpu/x86/build/kernelrel.dic
+command: &x86forth &dictionary &this
+build-now
+
+fload ${BP}/cpu/x86/tools.bth
Modified: forth/kernel/kernel.fth
==============================================================================
--- forth/kernel/kernel.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ forth/kernel/kernel.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -726,6 +726,9 @@
: ?comp (s -- ) state @ 0= ( -14 ) abort" Compilation Only " ;
: ?exec (s -- ) state @ ( -29 ) abort" Execution Only " ;
+: defined? ( "name" -- flag )
+ safe-parse-word $find dup if nip else nip nip then
+;
: $defined (s -- adr len 0 | xt +-1 ) safe-parse-word $find ;
: $?missing ( +-1 | adr len 0 -- +-1 )
dup 0= if drop .not-found ( -13 ) abort then
Modified: forth/lib/brackif.fth
==============================================================================
--- forth/lib/brackif.fth Fri Dec 2 02:04:52 2011 (r2718)
+++ forth/lib/brackif.fth Fri Dec 2 02:05:04 2011 (r2719)
@@ -30,13 +30,13 @@
: [then] ( -- ) ; immediate
-: [ifdef] ( "name" -- )
- $defined nip dup 0= if nip then postpone [if]
-; immediate
+: [ifdef] ( "name" -- ) defined? postpone [if] ; immediate
+: [ifndef] ( "name" -- ) defined? 0= postpone [if] ; immediate
+
+: \+ ( "name" "rest of line" -- ) defined? 0= if postpone \ then ; immediate
+: \- ( "name" "rest of line" -- ) defined? if postpone \ then ; immediate
+
-: [ifndef] ( "name" -- )
- $defined nip 0= dup if nip then postpone [if]
-; immediate
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: forth/wrapper/wrapper.c
==============================================================================
--- forth/wrapper/wrapper.c Fri Dec 2 02:04:52 2011 (r2718)
+++ forth/wrapper/wrapper.c Fri Dec 2 02:05:04 2011 (r2719)
@@ -958,18 +958,21 @@
}
f_close(f);
- code_size = ( (int)header.size_blocks -2)*0x200
- + (int)header.size_fragment ;
- code_wsize = (code_size+1) /2 ;
old_org = *(int*)(&loadaddr[0x1c]);
- delta_org = (int)loadaddr - old_org ;
- reloc_table = &loadaddr[code_size] ;
- for(i=0 ; i<code_wsize ; i++) {
- if(bittest(reloc_table, i)) {
- *(int*)(&loadaddr[2*i]) += delta_org ;
+ if (old_org != -1) {
+ /* Otherwise relocate lots of things via the bitmap */
+ code_size = ( (int)header.size_blocks -2)*0x200
+ + (int)header.size_fragment ;
+ code_wsize = (code_size+1) /2 ;
+ delta_org = (int)loadaddr - old_org ;
+ reloc_table = &loadaddr[code_size] ;
+ for(i=0 ; i<code_wsize ; i++) {
+ if(bittest(reloc_table, i)) {
+ *(int*)(&loadaddr[2*i]) += delta_org ;
+ }
}
+ memcpy(&loadaddr[dictsize], reloc_table, (code_size+15)/16);
}
- memcpy(&loadaddr[dictsize], reloc_table, (code_size+15)/16);
#else
@@ -1079,6 +1082,8 @@
int (*codep)();
/* There is a pointer to the startup code at offset 0x18 */
codep = (int (*)()) *(int *)(&loadaddr[0x18]);
+ if (old_org == -1)
+ codep = (int (*)())((int)codep + (int)loadaddr);
*(void **)(loadaddr+0x6) = fsyscall;
*(short *)(&loadaddr[0x0a]) = 0;
*(long *)(&loadaddr[0x10]) = argc;
More information about the openfirmware
mailing list