[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