meta.mu4

| This file is part of muforth: https://muforth.dev/
|
| Copyright 2002-2024 David Frech. (Read the LICENSE for details.)

loading RISC-V meta-compiler (main)

| ------------------------------------------------------------------------
| Macros defining register conventions
| ------------------------------------------------------------------------

assembler
\a a0  constant top
.ifdef native
\a ra  constant ip  ( instruction pointer)
.else
\a s1  constant ip  ( instruction pointer)
.then
\a s0  constant rp  ( return stack pointer; ABI: fp, frame pointer)
\a gp  constant kp  ( kernel origin pointer)  ( XXX needed?)
\a tp  constant up  ( "user" pointer - points to per-thread data)

( XXX these are outside of compressed instruction set's register range.)
\a s2  constant ix  ( loop index)
\a t0  constant w   ( scratch w, also "word" pointer)
\a t1  constant x   ( scratch x, also "execute" pointer)
\a t2  constant y   ( scratch y)
\a t3  constant z   ( scratch z)
forth

( Tell the disassembler about these register names.)
-:  ( reg)
   dup 0= if  drop  ." zero"  ^  then
   dup 16 u< if
.ifdef native
            z"    ip sp kp up w  x  y  rp s1 topa1 a2 a3 a4 a5 "
.else
            z"    ra sp kp up w  x  y  rp ip topa1 a2 a3 a4 a5 "
.then
   else
      16 -  z" a6 a7 ix s3 s4 s5 s6 s7 s8 s9 s10s11z  t4 t5 t6 "
   then
   swap 3 * + 3 -trailing type ;

: forth-regs  [ #] is .regname ;  forth-regs


| ------------------------------------------------------------------------
| Macros defining stack operations
| ------------------------------------------------------------------------
assembler

( XXX Macros or subroutines?)
( Data stack macros.)
: push1  ( r1)            asm{  -1 cells sp sp addi   0 sp rot ( r1) sw  } ;

: push2  ( r2 r1)         asm{  -2 cells sp sp addi   0 sp rot ( r1) sw
                                                   cell sp rot ( r2) sw  } ;

: push3  ( r3 r2 r1)      asm{  -3 cells sp sp addi   0 sp rot ( r1) sw
                                                   cell sp rot ( r2) sw
                                                2 cells sp rot ( r3) sw  } ;

: push4  ( r4 r3 r2 r1)   asm{  -4 cells sp sp addi   0 sp rot ( r1) sw
                                                   cell sp rot ( r2) sw
                                                2 cells sp rot ( r3) sw
                                                3 cells sp rot ( r4) sw  } ;

: pop1  ( r1)             asm{  0 sp rot ( r1) lw      cell sp sp addi  } ;

: pop2  ( r2 r1)          asm{  0 sp rot ( r1) lw
                             cell sp rot ( r2) lw   2 cells sp sp addi  } ;

: pop3  ( r3 r2 r1)       asm{  0 sp rot ( r1) lw
                             cell sp rot ( r2) lw
                          2 cells sp rot ( r3) lw   3 cells sp sp addi  } ;

: pop4  ( r4 r3 r2 r1)    asm{  0 sp rot ( r1) lw
                             cell sp rot ( r2) lw
                          2 cells sp rot ( r3) lw
                          3 cells sp rot ( r4) lw   4 cells sp sp addi  } ;

( Return stack macros.)
: rpush1  ( r1)      asm{   -1 cells rp rp addi   0 rp rot ( r1) sw  } ;

: rpush2  ( r2 r1)   asm{   -2 cells rp rp addi   0 rp rot ( r1) sw
                                               cell rp rot ( r2) sw  } ;

: rpop1  ( r1)       asm{  0 rp rot ( r1) lw      cell rp rp addi  } ;

: rpop2  ( r2 r1)    asm{  0 rp rot ( r1) lw
                        cell rp rot ( r2) lw   2 cells rp rp addi  } ;

forth


| ------------------------------------------------------------------------
| Signatures - how we built the target image
| ------------------------------------------------------------------------

meta
: string,  ( a u)
   \m here image+ swap  ( a image u)  dup \m allot  cmove ;

: cr,    #LF  \m c, ;  ( add a newline)
: sig,   \m string,  \m cr, ;

: sig"   char " parse  \m sig, ;

( Compile creation date, build command line, and muforth commit.)

: end-sig
   " created: "  \m string,  clock time"  \m sig,
   " command: "  \m string,
      " ./muforth " \m string,  command-line  count  \m sig,
   " commit : "  \m string,  muforth-commit drop 12  \m sig,
   #LF  \m align, ;

forth


| ------------------------------------------------------------------------
| Forward references for fundamental target kernel words.
| ------------------------------------------------------------------------
meta

( These are pointers to target CODE words.)
variable (branch)
variable (0branch)
variable (=0branch)
variable (?0branch)
variable (for)
variable (next)
variable (do)
variable (loop)
variable (+loop)
variable (lit)
variable (unnest)

forth

| Look up a label or forward-reference variable, and execute it to push
| its value or address.

: lookup
   .meta. chain' execute ;

: implements   \m here  lookup  ! ;

( Compile a pfa - for ITC - or a cfa - for native - into a target colon word.)
meta
.ifdef native
: compile,   asm{  ip jal  } ;
.else
: compile,   \m , ;  ( ITC)
.then
forth

( Fetch value of variable - a primitive - and complain if not yet defined.)
: (p@)  ( var)  @  =if  ^  then  error" primitive not yet defined" ;

( Fetch primitive and compile into target.)
: (p,)  ( var)  (p@)  \m compile, ;

compiler
: p,   .meta. \chain  compile (p,) ;
: p@   .meta. \chain  compile (p@) ;
forth


| ------------------------------------------------------------------------
| Creating new target names
| ------------------------------------------------------------------------

.ifdef notyet  ( vectors)

( XXX How do we do vectors in RISC-V land?)
: unvectored?  ( offset - f)  image-@  "0ffff_ffff = ;

meta
: handler  ( vector-offset)  \m here swap  image-!  __asm ;

( Set all unset vectors to point to this vector - usually RESET.)
: default-handler  ( start-vector default-vector)
   \m handler  ( force it, in case it's been set already)
   ( then set all unset handlers to this address)
   \eq Vreset  swap do
      i unvectored? if  i  \m handler  ( set it)  then
   \m cell +loop ;

.then  ( vectors)


variable last-code   ( for ;code and does> to fix up)

| Create new target names. A name is a target word which is defined as a
| _constant_ equal to its parameter field address, for ITC, or its code
| field address, for native code.

| labels are always created in .labels.
|  names are always created in .target.
|
| Target words annotated with [r] will be moved from .target. to
| .target-runtime.

meta
: [r]   ( mark as "runtime"; move last .target. word into .target-runtime.)
   .target. @  dup @  ( last prev)  .target. !  ( unlink)
   .target-runtime. @  ( last last-runtime)  over .target-runtime. !
   swap ! ( link our new word to last-runtime) ;

: label   current preserve  .labels. definitions  \m here  constant  __asm ;
: name    current preserve  target  \m here  constant ;
: code,   \m here last-code !  ( make a code field)  "deadc0de \m , ;

.ifdef native

( Created constant contains target cfa, not pfa!)
: new    \m name  \m code, ;  ( for words with code fields)
: code   \m name  __asm ;

.else  ( ITC)

( Created constant contains target pfa, not cfa!)
: new     \m code,  \m name ;  ( for words with code fields)
: codes   ( 'code)  \m ,  \m name  __asm ;
: code    \m here  \m cell+  \m codes ;

.then

( For code words that implement forward-referenced meta-compiler primitives.)
: code*   \m code  untoken  implements ;


| For forward references. Use hook to define the hook. This creates a label
| and compiles a jump. Then resolve using hooks, which patches the jump to
| point to here.
|
| NOTE: the label points at the code *immediately after* the hook, not the
| hook itself. This makes fixup easier, but can be confusing if you want to
| disassemble the code for a particular hook!

meta
: hook    \m label  asm{  here j  } ;  ( compile a jump with 0 offset)
: hooks   lookup  \m here  ( src dest)  \a resolve ;
forth


| ------------------------------------------------------------------------
| Support for ;code
| ------------------------------------------------------------------------

| This word, which is followed inline by a target code address, replaces
| with the inline target address the code field of the last word compiled .
| It re-defines the behaviour of a previously defined word - defined by
| create, variable, constant, etc - by changing its runtime code. It gets
| -compiled- indirectly by both ;code and does>.

.ifdef native
( NOTE: Do the  pop @  before the  h @ preserve  else R stack mayhem ensues.)
: (;code@)   pop @  h @ preserve  last-code @  \m goto  asm{  w jal  } ;
.else
: (;code@)   pop @  last-code @  image-! ;  ( ITC)
.then

| <;code> is used to switch from compiling -host- code (that will later run
| on the host, and build the target word) to compiling -target- code, that
| will run when words defined by this defining word later execute. In order
| to connect the two worlds, and to be able to patch up code fields to
| point to this newly-defined behaviour, <;code> captures the target's
| "here" value. Remember, we are about to start compiling target code at
| "here".
|
| <;code> runs at the compile time of a defining word, but it leaves it up
| to its caller - ;code or does> - to change the interpreter mode.

: <;code>   compile (;code@)  \m here  ,  show ;

definer
: ;code   <;code>  __asm ;
forth


| ------------------------------------------------------------------------
| Control structures.
| ------------------------------------------------------------------------

( Resolve a forward or backward jump, from src to dest.)
( When using absolute branch addresses, this is easy: just store dest at src.)

meta
: <resolve  ( dest src)  image-! ;
: >resolve  ( src dest)  swap  \m <resolve ;
: mark   \m here  0 \m , ;

target-compiler
: =if   ( - src)        p, (=0branch)  \m mark ;
: ?if   ( - src)        p, (?0branch)  \m mark ;
: if    ( - src)        p,  (0branch)  \m mark ;
: then  ( src)          \m here  \m >resolve ;
: else  ( src0 - src1)  p,   (branch)  \m mark  swap  \tc then ;

: begin   ( - dest)  \m here ;
: =until  ( dest -)  \tc =if  \m <resolve ;
: ?until  ( dest -)  \tc ?if  \m <resolve ;
: until   ( dest -)  \tc  if  \m <resolve ;
: again   ( dest -)  p, (branch)  \m mark  \m <resolve ;
: =while  ( dest - src dest)  \tc =if  swap ;
: ?while  ( dest - src dest)  \tc ?if  swap ;
: while   ( dest - src dest)  \tc  if  swap ;
: repeat  ( src dest -)   \tc again  \tc then ;

| NOTE: We only implement the "smart" for that loops 0 times when passed a
| zero. No more "special case" loops of the form:
|   ?for  blah blah  next  then
| Now, for compiles ?if followed by the for runtime; next compiles the next
| runtime, resolves the backwards branch for next, and, lastly, resolves
| the forward branch from the ?if.

( n for .. next         goes n times; 0 if n=0 )

: for     ( - src dest)  \tc ?if  p, (for)  \tc begin ;
: next    ( dest -)      p, (next)  \m mark  \m <resolve  \tc then ;

( do, loop, +loop)
: do      ( - dest)   p, (do)             \tc begin ;
: loop    ( dest)     p, (loop)   \m mark  \m <resolve ;
: +loop   ( dest)     p, (+loop)  \m mark  \m <resolve ;
forth


| ------------------------------------------------------------------------
| Special versions of host colon compiler
| ------------------------------------------------------------------------

| Define useful colon compilers:
|     meta:  for defining new target defining words!
|  definer:  for defining meta-compiler-specific compiling words
|
| We will define another colon compiler - the actual target colon - in the
| kernel, using our meta-defining words!

| We need meta: so we can define defining words in the middle of target
| code - eg, the kernel. It gives us an easy way to fire up a specific
| colon compiler - the one specifically *tuned* for making target defining
| words.
|
| definer: is similar. It runs the same colon compiler as meta: but puts
| the new word on the .definer. chain. Its use is rather obscure, and hard to
| explain. ;-)

meta
: meta:     current preserve  meta     :  __definer-colon ;
: definer:  current preserve  definer  :  __definer-colon ;
forth


| ------------------------------------------------------------------------
| Utility words from .forth. copied into .meta.
| ------------------------------------------------------------------------
( Sign extend target value.)
: sext32  ( n -n')   dup "8000_0000 and if  "-1_0000_0000 +  then ;

meta

: .   sext32  . ;  ( sign-extend, then print as a signed value)

.ifdef no-forth-while-chatting
: .s   .s ;
: u.   u. ;
: sp-reset   sp-reset ;

: words   words ;
: all-words   all-words ;

: forth   forth ;
: meta   meta ;
: assembler   assembler ;
: target   target ;
: target-compiler   target-compiler ;

: hex  hex ;
: decimal   decimal ;
: octal   octal ;
: binary   binary ;
.then

forth

| ------------------------------------------------------------------------
| Punctuation that changes the compiler state, or creates literals
| ------------------------------------------------------------------------

meta
| ' get target word's constant value: its pfa
| We search runtime words too, so we can du or dis them.

: '   .target-runtime. chain' execute ;
: >value  image-@ ;

: literal    p, (lit)  \m , ;  ( make a target literal)

: ]   __target-colon ;  ( does NOT create a literal!)
: #]  \m ]  \m literal  ;   ( DOES create a literal!)

: __host   \ [ ;        ( return to host forth mode)
: {        \m __host ;  ( useful for bracketing a few host forth words)

forth
: }    __meta ;  ( return to meta)

assembler
: ;c   __meta ;

target-compiler
: [   __meta ;
: ^    p, (unnest) ;  ( compile target's unnest)
: ;   \tc ^  \tc [ ;  ( compile exit and return to meta)

: [']        \m '  \m literal ;
: literal          \m literal ;

definer
: ;   \ ;  __meta ;  ( do normal host ; but then return to __meta)

forth

( Patch target colon compiler.)
.meta. chain' literal   is target-literal
             ' number   is target-number    ( use host's number)
.meta. chain' compile,  is target-compile,