meta.mu4

( This file is part of muforth: https://muforth.dev/

  Copyright 2002-2024 David Frech. (Read the LICENSE for details.)

loading ARM v6-M meta-compiler (main)

( NOTE: While you will see .ifdef native in a few places in this file, the
  current development "push" is toward an ITC - indirect-threaded code -
  system.)

( Register conventions.

  Let's start with the ARM procedure call spec:

  "a" registers are used to pass arguments, or as scratch registers. All
  are caller-saved.

  "v" registers are value registers, and are callee-saved.

  ARM procedure call spec says that how r9 is treated is "platform-specific",
  so we should refrain from using it as anything but a scratch register.

  r0 to r3 and r12 are saved and restored by the interrupt-handling
  hardware.

  Here's out it lays out:

  Reg  ABI  Forth  Comments
  ===  ===  =====  =======================================================
   r0   a1    w    These four are argument or scratch regs for the ABI, and
   r1   a2    x    scratch registers for Forth. All are caller-saved. All
   r2   a3    y    four are also saved by interrupt hardware.
   r3   a4    z

   r4   v1    ix   Forth: loop index or counter
   r5   v2    rp   Forth: return stack pointer
   r6   v3    ip   Forth: interpreter pointer
   r7   v4    top  Forth: cached top of data stack

   r8   v5    up   Forth user pointer.
   r9   v6    --
  r10   v7    --
  r11   v8    --   ABI: frame pointer or v8

  r12   ip    --   ABI: inter-procedure scratch. Saved by interrupt hardware.
  r13   sp    sp   hardware stack pointer; Forth's data stack pointer
  r14   lr    lr   hardware link register; mostly unused by Forth
  r15   pc    pc   hardware program counter
)

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

assembler
( Low registers.)
\a r0  constant w   ( scratch w, also "word" pointer)
\a r1  constant x   ( scratch x, also "execute" pointer)
\a r2  constant y   ( scratch y)
\a r3  constant z   ( scratch z)

( NOTE: ix is currently *not* being used in the kernel.)
\a r4  constant ix  ( loop index, for for/next and do/loop/+loop)
\a r5  constant rp  ( return stack pointer)
\a r6  constant ip  ( instruction pointer)
\a r7  constant top

( High registers.)
\a r8  constant up  ( "user" pointer - points to per-task data)

forth

( Tell the disassembler about these register names. It already knows about
  the ABI names.)

-: ( reg)
   15 and  3 *
   z" w  x  y  z  ix rp ip topup r9 r10r11r12sp lr pc " +  3 -trailing type ;

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

-- ------------------------------------------------------------------------
-- 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 forward-reference variable, and execute it to push its value or
  address.)

: lookup
   .meta. chain' execute ;

: implements   \m here  lookup  ! ;

( Compile a cfa into a target colon word.)
meta
.ifdef native
: compile,   asm{{  c  }} ;
.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


-- ------------------------------------------------------------------------
-- Exception vectors and vector table
-- ------------------------------------------------------------------------

.equates. .contains LAST_irq  .if

( Address of start of vector table.)
variable @vectors
: +vectors  @vectors @ + ;

( Capture address of vector table and allot space for it in flash or ram.

  According to the v6-M and v7-M architecture reference manuals, the vector
  table *origin* should be 32-word aligned, or aligned to a 128 byte boundary.
  The bottom seven bits are zero.

  We align the *size* of the vector table to a multiple of 16, for
  neatness, and so it's easy to read using "du".

  You should supply a reset SP value or 0 to vector-table. If you use 0,
  the top of ram will be used as the reset SP.)

: vector-table  ( reset-sp)
   ( Calculate the reset SP value.)
   dup 0= if  drop  @ram #ram + ( use default: top of ram)  then

   create
      \m here  ( in current region)
      [ 32 \m cells #] aligned-by  ( this is *origin* alignment)
      dup \m goto  ( set here to origin)
      dup , ( origin)  image-! ( set first cell of table to reset SP)
      \eq LAST_irq  16 aligned-by  \m allot  ( allot space)
   does> @  @vectors ! ;

: unvectored?  ( offset - f)  +vectors image-@  "0ffff_ffff = ;

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

( Set all unset vectors to point to "here".)
: default-handler
   \eq LAST_irq  \m cell ( from RESET to LAST) do
      i unvectored? if  i  \m handler  ( set it)  then
   \m cell +loop ;

forth

.then  ( LAST_irq in .equates.)


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

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 code field address - for both ITC and 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. addr@  dup addr@  ( last prev)  .target. addr!  ( unlink)
   .target-runtime. addr@  ( last last-runtime)  over .target-runtime. addr!
   swap addr! ( link our new word to last-runtime) ;

: label   current preserve  .labels. definitions  \m here  constant  __asm ;
: name    current preserve  target  \m align  \m here  constant ;

: code,   \m here last-code !  ( make a code field)  "deadc0de \m , ;
: new     \m name  \m code, ;  ( for words with code fields)

: codes   ( 'code)  \m name  1+ \m ,  __asm ;
: code    \m align  \m here  \m cell+  \m codes ;

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


.ifdef notyet  ( hooks)

( For forward references. Use hook to define the hook. This creates a label
  and compiles a long jump. Then resolve using hooks, which patches the jmp
  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!)

forth
: hook!   ( to from)  \m cell-  image-! ;
meta

( NOTE: We can't use  asm{  0  }  when creating the hook code because
  that will get converted to a constant generator form! We need to compile
  a version with space in the following word for the absolute or relative
  address that will get patched by "hooks".)

.ifdef hooks-are-relative

( Hooks using PC-relative addressing.)
: hook    asm{  "0666 pc add  }  state preserve  \m label ;
: hooks   \m here  lookup  ( to from)  tuck  - swap  hook! ;

.else

( Hooks using absolute addressing.)
: hook    asm{  "0666 br  }      state preserve  \m label ;
: hooks   \m here  lookup  ( to from)                hook! ;

.then

.then   ( hooks)

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{  bl  } ;
.else
: (;code@)   pop @  1+ ( thumb!)  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


-- ------------------------------------------------------------------------
-- Support for in-line literals (literal pool, ARM-style)
-- ------------------------------------------------------------------------

( The two workhorses are:

  - lit   an assembler pseudo-instruction that does three things:
     - adds the literal value to the lit table if it isn't present, and
       reuses the existing value if it is

     - using the *index* into the lit table, creates an ldr instruction and
       compiles it

     - pushes the address of the ldr instructions onto a stack of "refs"
       that need to fixed up [once the table is compiled into the image and
       we know its address]

  - pool,   a meta word that does two things:
     - compiles the literal table into the image

     - for every ref on the fixup stack, updates the ldr instruction with
       the offset to the [compiled] literal table.

  The idea is that you can freely use literals, whose values will be
  re-used if possible. IE, in a given, compiled, literal table, there will be
  no repeated values.

  For this to be as efficient as possible, it's important to try to defer
  the use of  pool,  for as long as possible. But there is no good way to do
  this! In particular, there are no warnings that the literal table - or
  the stack of refs - is getting full.)

( The literal table, as it is being constructed.)
32 array+ lit-values  ( room for 32 literal values)
variable lit-value    ( ranges from 0 to 32)

: lit-exists?  ( lit - index -1 | 0)
   push  0 ( index)
   begin
      dup lit-value @ u< while
      dup lit-values @ r@ = if  ( matched)  rdrop  -1 ^  then
   1+ repeat
   rdrop drop 0 ;

( Return the index of an existing or newly-created literal.)
: lit-new  ( lit - index)
   dup lit-exists? if nip ^ then
   lit-value @ tuck  lit-values !  1 lit-value +! ;

( The stack of refs to instructions needing fixing up.)
64 array+ lit-refs    ( room for 64 literal *references*)
variable lit-ref      ( ranges from 0 to 64)

: lit-push  ( ref)                    lit-ref @ lit-refs !  1 lit-ref +! ;
: lit-pop   ( - ref)   -1 lit-ref +!  lit-ref @ lit-refs @ ;

assembler
: lit   ( lit reg8)
   \m here  lit-push  ( onto ref stack)
   swap lit-new  ( reg8 index)  "4800 i8 r000 op,  ( <index> pc reg8 ldr) ;

forth
: h+!   ( n a)   tuck leh@ +  swap leh! ;

: lit-fixup  ( ref lit-table)
   over >load-pc -  \m cell/  ( calc offset from ldr to literal table start)
   swap image+ h+! ( add offset into ldr instruction!) ;

meta
: pool,
   \m align  \m here push  ( address of lit table)
   0 lit-values  lit-value @ for  @+ swap \m ,  next  drop  lit-value off
   begin  lit-ref @ while  lit-pop r@ lit-fixup  repeat  rdrop ;

forth


.ifdef native

-- ------------------------------------------------------------------------
-- Peephole optimiser
-- ------------------------------------------------------------------------
( Tags used:)
1 constant $lit1  ( one instruction lit: ldr or movs #)
2 constant $lit2  ( two instruction lit: movs+mvns or movs+lsls)
3 constant $call  ( $ suggests price tag ;-)

: tag!  ( tag)  \m here  image-h! ;
: tag@          \m here  image-h@ ;
: notag   -1 tag! ;  ( set to all ff's)

: is-lit-tag?  ( tag - f)  $call u< ;

: uncompile  ( #instrs)
   notag
   \m here  swap  for  -2  -1 ( 0ffff) over  image-h!  next  org ;


-- ------------------------------------------------------------------------
-- Smart jump, and tail call elimination
-- ------------------------------------------------------------------------

( Smart jump: compile short unconditional branch if possible;
  otherwise, ldr + bx.

  Smart call: compile bl if possible; otherwise, ldr + blx)

assembler
: j  ( dest)
   dup  \m here  branch-offset  bra?  if  op,  drop  ^  then
   drop  1+ ( thumb!)  \a r0 lit,  <asm  r0 bx  asm> ;

: c  ( dest)
   dup  \m here  branch-offset  bl?  if  op32,  drop  ^  then
   drop  1+ ( thumb!)  \a r0 lit,  <asm  r0 blx  asm> ;
forth

( If last code compiled was a call, rewrite it to a jump and return true;
  else return false.

  NOTE: 'then' should clobber tag so that  if b then ;  doesn't
  tail-convert the call to b and neglect to put a  bx lr  at the end of the
  word!)

( An unusual word that we haven't needed until now!)
: image-op32@  ( a - op32)
   dup image-h@ 16 <<  swap 2 + image-h@ + ;

: tail?  ( - f)
   tag@ $call = if  notag
      -4 \m allot  \m here  dup >branch-pc
      swap image-op32@  bl-offset@  ( op offset)  nip
      hoff>  +  ( dest)  \a j  -1  ^  then
   0 ;

meta-compiler
: ^   tail? if ^ then  <asm  lr bx  asm> ;

meta
: compile,  ( target-cfa)  \a bl  ( compile call)  $call tag! ;

forth

-- ------------------------------------------------------------------------
-- Literal loading
-- ------------------------------------------------------------------------

( Try three ways to load a literal:
  * movs k, #i8
  * movs k, #i8; mvns k, k
  * movs k, #i8; lsls k, k, #n
  Failing that, use  lit,  to compile an ldr from the literal pool.)

: load-literal  ( n - tag)
   "ffff_ffff and  ( we only care about 32 bits!)

   ( Try a simple movs)
   dup 8 ufits? if  <asm  k movs  asm>  $lit1  ^  then

   ( Try movs followed by mvns)
   dup  "ffff_ffff xor
   dup 8 ufits? if  nip  <asm  k movs  k k mvns  asm>  $lit2  ^  then
   drop ( inverted)

   ( Try movs followed by lsls)
   dup push  0 ( shift)  r@
   begin  u2/  1 u+  dup 8 ufits?  until ( n shifts shifted)
   2dup swap <<  pop = if  <asm  k movs  k k lsls  asm>  drop  $lit2  ^  then
   2drop

   ( No luck. Compile an ldr from literal pool.)
   \a k lit,  $lit1 ;

.then  ( native: literals and such)


-- ------------------------------------------------------------------------
-- 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 ;
: compiler:  current preserve  target-compiler  :  __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 cfa
  We search runtime words too, so we can du or dis them.)

: '   .target-runtime. chain' execute ;
: >body   \m cell+ ;
: >value  \m >body  image-@ ;

( A useful shortcut for getting the address of a target word's value while
  assembling. This is a *hack*, and should probably be replaced by some
  other technique, but it works and it's easy to read and write.

  Two other possibilities:

    * Have the assembler search .target. and push the code field address of
      any word it finds; we can then use >body and >value as necessary;

    * define 'b and 'v, which combine ' and >body or ' and >value.

  This is an ugly problem with no pretty solutions.)

assembler
: >v  ( "value")   \m '  \m >value ;
meta

: 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,