needs xcomp/tools
$80000000 to binstart

\ Macros
: xnip, addi) xPSP xPSP 4 3p) ,) ;
: xdrop, xW ppop, ;
: xgrow, addi) xPSP xPSP -4 3p) ,) ;
: xdup, xW ppush, ;
: pushlr, xRA push, ;
: poplr, xRA pop, ;
: popexit, poplr, ret, ; \ impossible to do it like on ARM port
: abscall, pushlr, absbl, poplr, ;
: wcall, xwordlbl abscall, ;
: wjmp, xwordlbl absb, ; \ only for leaf words!

: pc'>reg, ( pc r -- )
  dip pc swap- | ( off r )
  dup pc>reg,
  addi) swap rdrs1) swap neg imm) ,) ;

: pc@>reg, ( pc r -- )
  dip pc swap- | ( off r )
  dup pc>reg,
  lw) over rd) swap base) swap neg imm) ,) ;

: xconst ( n -- ) pc swap le, xcode xdup, xW pc@>reg, ret, ;

: values ( n -- ) 0 do 0 value loop ;
8 values lblcwrite lbldwrite lblwriterange lblbaseboot
         lblcoldboot lblccache lblUimm lblJimm
$800 const STACKSZ

: HERE@, ( dstreg ptrreg -- )
  lw) over xSYSVARS oCURALLOC 3p) ,)
  lw) rot rd) swap base) ,) ;

\ SYSVARS placement done in the ARM-style
kernelbegin
forward8 [jmp] j) ,) to lblcoldboot \ binstart + 4. SYSVARS => can fit in one instr
\ but might be better to put a far jump here
\ if we put a far jump, every sysvars will be misplaced (by 4)
0 le, \ COMPILING
binstart oSYSALLOC + le, \ CURALLOC
0 le, \ SYSDICT
0 le, \ unused
0 le, \ RCNT
0 le, \ FINDCOMPILER
$80080000 le, \ SYSALLOC HERE
0 le, \ SYSALLOC HEREMAX
0 le, \ SYSALLOC NEWHERE
0 le, \ INPTR
$14 allot0 \ unused
0 le, \ SYSVARS+40=/mod pointer => unused on RISC-V because using the Mul extension we have / and mod
0 le, \ unused
$83000000 STACKSZ - le, \ PSORIGIN
STACKSZ le, \ PSSZ
$83000000 le, \ RSORIGIN
binstart SYSVARSSZ + tgtallot

$30 xconst ARCH

\ make all them take 2 instructions slot because they will be realiased later with far jump
xcode (wnf) j) 0 imm) ,) j) 0 imm) ,)
xcode (div0) j) 0 imm) ,) j) 0 imm) ,)
xcode bye j) 0 imm) ,) j) 0 imm) ,)

pc to L3 \ fail
  xW 0 li,
  ret,

xcode parsehex ( a u -- n? f ) \ *without* the $
  mv) x10 xW 2p) ,)
  xdrop,
pc to L2 \ x10=u xW=a
  beq) x10 xZERO L3 abs>rel 3p) ,)
  x12 0 li, \ x12=accumulated result
pc \ loop
  lbu) x11 xW 0 3p) ,)
  addi) xW xW 1 3p) ,)
  addi) x10 x10 -1 3p) ,)
  ori) x11 x11 $20 3p) ,)
  x15 '0' li,
  bltu) x11 x15 L3 abs>rel 3p) ,)
  sub) x11 x11 x15 3p) ,)
  x15 10 li,
  forward8 [jmp] bltu) x11 x15 2p) ,) \ parse ok, under 10
    addi) x11 x11 'a' '0' swap- 3p) ,)
    x15 6 li,
    bge) x11 x15 L3 abs>rel 3p) ,)
    addi) x11 x11 10 3p) ,)
  forward! \ parse ok, digit in x11
  slli) x12 x12 4 3p) ,)
  add) x12 x12 x11 3p) ,)
  bne) x10 xZERO 2p) swap ( loop ) abs>rel imm) ,)
  x12 ppush,
  xW 1 li,
  ret,

xcode parse ( str -- n? f )
  lbu) x11 xW 1 3p) ,)
  x15 '$' li,
  bne) x11 x15 L3 abs>rel 3p) ,)
  lbu) x10 xW 0 3p) ,)
  addi) x10 x10 -1 3p) ,)
  addi) xW xW 2 3p) ,)
  L2 absb,

xcode word ( -- str )
  lw) x11 xSYSVARS oINPTR 3p) ,) \ x11=addr
  pc
    lbu) x10 x11 0 3p) ,)
    addi) x11 x11 1 3p) ,)
    x19 SPC li,
    ( pc ) ble) x10 x19 2p) swap abs>rel imm) ,) \ x10=first non-ws
  xdup, addi) xW x11 -2 3p) ,) \ xW=res
  pc
    lbu) x10 x11 0 3p) ,)
    addi) x11 x11 1 3p) ,)
    x19 SPC li,
    bgt) x10 x19 2p) swap abs>rel imm) ,)
  sw) x11 xSYSVARS oINPTR 3p) ,)
  sub) x11 x11 xW 3p) ,)
  addi) x11 x11 -2 3p) ,)
  sb) x11 xW 0 3p) ,)
  ret,

xcode execute ( a -- )
  mv) x10 xW 2p) ,)
  xdrop,
  jalr) x0 x10 0 3p) ,)

xcode findentry ( name 'dict -- e-or-0 )
  x12 ppop, \ x12=name xW=dict
  sw) x12 xSYSVARS oFINDSTR 3p) ,)
  x17 $3fffffff li, \ x17=lenmask
  lbu) x11 x12 0 3p) ,) \ x11=len
  slli) x16 x11 24 3p) ,) \ x16=tofind
  add) x13 x11 x12 3p) ,) \ x13=lastchar
  lbu) x10 x13 0 3p) ,) \ x10=lastchar
  slli) x19 x10 16 3p) ,)
  or) x16 x16 x19 3p) ,)
  x19 2 li,
  forward8 [jmp] bltu) x11 x19 2p) ,)
    lbu) x10 x13 -1 3p) ,)
    slli) x18 x10 8 3p) ,)
    or) x16 x16 x18 3p) ,)
  forward!
  forward8 [jmp] bleu) x11 x19 2p) ,)
    lbu) x10 x13 -2 3p) ,)
    or) x16 x16 x10 3p) ,)
  forward!
pc \ loop1
  lw) x13 xW -4 3p) ,)
  and) x13 x13 x17 3p) ,)
  forward8 [jmp] beq) x16 x13 2p) ,)
    pc to L1 \ not matching, try next
    lw) xW xW 0 3p) ,)
    swap bne) xW xZERO 2p) swap abs>rel imm) ,)
    \ not found
    ret,
  forward!
  \ same length
  addi) x14 xW -2 3p) ,)
  sub) x14 x14 x11 3p) ,) \ x14=beginning of name range
  mv) x13 x11 2p) ,) \ x13=running len
pc \ loop 2
  add) x18 x14 x13 3p) ,)
  lbu) x15 x18 0 3p) ,)
  add) x18 x12 x13 3p) ,)
  lbu) x10 x18 0 3p) ,)
  bne) x15 x10 2p) L1 abs>rel imm) ,)
  addi) x13 x13 -1 3p) ,)
  bne) x13 xZERO 2p) swap abs>rel imm) ,)
  \ same contents
  ret,

xcode HERE xdup, lw) xW xSYSVARS oCURALLOC 3p) ,) ret,

pc to lblcwrite \ x10=char. out: x11=here x12=hereptr
  x11 x12 HERE@,
  sb) x10 x11 0 3p) ,)
  addi) x11 x11 1 3p) ,)
  sw) x11 x12 0 3p) ,)
  ret,

xcode , ( n -- )
  mv) x10 xW 2p) ,) xdrop,
pc to lbldwrite \ x10=n. out: x11=here x12=hereptr
  x11 x12 HERE@,
  sw) x10 x11 0 3p) ,)
  addi) x11 x11 4 3p) ,)
  sw) x11 x12 0 3p) ,)
  ret,

pc to lblwriterange \ x10=addr x11=len
  forward8 [jmp] bne) x11 xZERO 2p) ,)
    ret,
  forward!
  x12 x13 HERE@,
  pc
    lbu) x14 x10 0 3p) ,)
    addi) x10 x10 1 3p) ,)
    sb) x14 x12 0 3p) ,)
    addi) x12 x12 1 3p) ,)
    addi) x11 x11 -1 3p) ,)
    bne) x11 xZERO 2p) swap abs>rel imm) ,)
  sw) x12 x13 0 3p) ,)
ret,

xcode alignhere ( -- ) \ output: x10=here x12=hereptr
  x10 x12 HERE@,
  andi) x11 x10 3 3p) ,)
  forward8 [jmp] beq) x11 xZERO 2p) ,)
    addi) x10 x10 4 3p) ,)
    sub) x10 x10 x11 3p) ,)
    sw) x10 x12 0 3p) ,)
  forward!
  ret,

xcode entry[] pushlr, ( 'dict a u -- )
  xwordlbl alignhere absbl, \ x10=here x12=hereptr
  sw) xZERO xSYSVARS oRCNT 3p) ,)
  mv) x15 xW 2p) ,) \ x15=len
  x16 ppop, \ x16=a
  addi) xW x15 1 3p) ,) \ xW=len+1
  andi) xW xW 3 3p) ,)
  forward8 [jmp] beq) xW xZERO 2p) ,)
    sw) xZERO x10 2p) ,)
    sub) x10 x10 xW 3p) ,)
    addi) x10 x10 4 3p) ,)
    sw) x10 x12 2p) ,)
  forward!
  xdrop, \ xW='dict
  mv) x10 x16 2p) ,)
  mv) x11 x15 2p) ,)
  lblwriterange absbl,
  mv) x10 x15 2p) ,)
  lblcwrite absbl, \ x11=here
  lw) x10 xW 0 3p) ,) \ x10=dict
  sw) x11 xW 0 3p) ,) \ "here" is new 'dict
  xdrop,
  poplr,
  lbldwrite absb,

xcode code
  xdup, addi) xW xSYSVARS oSYSDICT 3p) ,)
  wcall, word
  addi) x19 xW 1 3p) ,)
  x19 ppush,
  lbu) xW xW 0 3p) ,)
  wjmp, entry[]

pc xdup, auipc) xW 0 2p) ,) addi) xW xW 12 3p) ,) ret,
xcode create
  wcall, code
  ( pc ) x10 pc'>reg,
  x11 20 li,
  lblwriterange absb,

xcode or x10 ppop, or) xW xW x10 3p) ,) ret,
xcode and x10 ppop, and) xW xW x10 3p) ,) ret,
xcode xor x10 ppop, xor) xW xW x10 3p) ,) ret,
xcode invand not) xW rdrs1) ,) wjmp, and
xcode lshift x10 ppop, sll) xW x10 xW 3p) ,) ret,
xcode rshift x10 ppop, srl) xW x10 xW 3p) ,) ret,
xcode + x10 ppop, add) xW xW x10 3p) ,) ret,
xcode - x10 ppop, sub) xW x10 xW 3p) ,) ret,
xcode bool sltu) xW xZERO xW 3p) ,) ret,
xcode not sltiu) xW xW 1 3p) ,) ret,
xcode dup xdup, ret,
xcode drop xdrop, ret,
xcode swap
  lw) x10 xPSP 2p) ,)
  sw) xW xPSP 2p) ,)
  mv) xW x10 2p) ,)
  ret,
xcode over
  xdup,
  lw) xW xPSP 4 3p) ,)
  ret,
xcode rot
  lw) x10 rd) xPSP base) ,)
  sw) xW src) xPSP base) ,)
  lw) xW xPSP 4 3p) ,)
  sw) x10 xPSP 4 3p) ,)
  ret,
xcode @ lw) xW rd) xW base) ,) ret,
xcode c@ lbu) xW rd) xW base) ,) ret,
xcode !
  x10 ppop,
  sw) x10 src) xW base) ,)
  xdrop,
  ret,
xcode c!
  x10 ppop,
  sb) x10 src) xW base) ,)
  xdrop,
  ret,

\ HAL operations
\ x10 is used as the immediate accumulator
\ x11 is used as the source value accumulator

\ Used by 2instr sequence instructions allowing to load immediates
\ similar to _hi asm macro, preserves x10 and x11 and x12
xcode hibits ( n -- n:31-12>>12 )
  srli) x14 xW 11 3p) ,)
  srli) xW xW 12 3p) ,)
  andi) x14 x14 1 3p) ,)
  add) xW xW x14 3p) ,)
  ret,

\ insert immediate in "I type" of instructions, preserves x11 and x12
xcode Iimm! ( instr n -- instr )
  x10 ppop,
  slli) x10 x10 12 3p) ,)
  srli) x10 x10 12 3p) ,) \ clean instr high bits
  slli) xW xW 20 3p) ,)
  or) xW xW x10 3p) ,)
  ret,

\ insert immediate in "U type" of instructions, preserves x11 and x12
pc to lblUimm ( n -- ) \ input/output: x10=instr
  slli) x10 x10 20 3p) ,)
  srli) x10 x10 20 3p) ,) \ clean instr high bits
  slli) xW xW 12 3p) ,)
  or) x10 x10 xW 3p) ,)
  xdrop, ret,

\ same as lblUimm with "J-type", must preserve x11 and x12
xcode Jimm!
  x10 ppop,
pc to lblJimm ( n -- instr ) \ x10=instr
  slli) x10 x10 20 3p) ,)
  srli) x10 x10 20 3p) ,) \ clear upper bits
  x13 $ff000 li,
  and) x14 xW x13 3p) ,)
  or) x10 x10 x14 3p) ,)
  andi) x14 xW $7fe 3p) ,)
  slli) x14 x14 20 3p) ,) \ 20=21-1
  or) x10 x10 x14 3p) ,)
  srli) x14 xW 11 3p) ,)
  andi) x14 x14 1 3p) ,)
  slli) x14 x14 20 3p) ,)
  or) x10 x10 x14 3p) ,)
  srli) xW xW 20 3p) ,)
  andi) xW xW 1 3p) ,)
  slli) xW xW 31 3p) ,)
  or) x10 x10 xW 3p) ,)
  mv) xW x10 2p) ,)
  ret,

\ Insert 32-bit imm into two sequence instructions allowing to load immediates (li or la)
pc lui) x0 rd) 0 imm) ,) addi) x0 x0 0 3p) ,)
xcode loadimm, ( reg n -- )
  x11 ppop,
  dup x10 pc@>reg,
  pushlr, xdup, wcall, hibits lblUimm absbl, poplr,
  slli) x11 x11 7 3p) ,)
  or) x10 x10 x11 3p) ,)
  x11 ppush, pushlr, lbldwrite absbl, poplr, x11 ppop, \ lui instr written
  4 + x10 pc@>reg,
  x10 ppush,
  wcall, Iimm!
  or) xW xW x11 3p) ,)
  slli) x11 x11 8 3p) ,)
  \ addi instruction add missing bits to already written in Rd
  or) xW xW x11 3p) ,)
  wjmp, ,

\ non-null return value if number overflows 12 bits
xcode ?>12b ( n -- ovfl )
  srai) xW xW 11 3p) ,)
  addi) xW xW 1 3p) ,)
  andi) xW xW -2 3p) ,)
  ret,

\ Compile code resulting in register Rd to contain "n"
pc addi) xZERO xZERO 0 3p) ,)
xcode imm, ( reg n -- )
  xdup,
  wcall, ?>12b
  mv) x19 xW 2p) ,)
  xdrop,
  bne) x19 xZERO 2p) xwordlbl loadimm, abs>rel imm) ,)
  x11 ppop,
  x10 pc@>reg,
  x10 ppush,
  wcall, Iimm!
  slli) x11 x11 7 3p) ,)
  or) xW xW x11 3p) ,)
  wjmp, ,

pc pushlr, \ generate two instructions
xcode pushlr,
  ( pc ) x10 pc'>reg, x11 8 li, lblwriterange absb,

pc poplr, \ generate two instructions
xcode poplr,
  ( pc ) x10 pc'>reg, x11 8 li, lblwriterange absb,

pc popexit, \ generate three instructions
xcode popexit,
  ( pc ) x10 pc'>reg, x11 12 li, lblwriterange absb,

pc ret,
xcode exit,
  ( pc ) x10 pc@>reg, lbldwrite absb,

\ Used to write 2-instructions far call
\ x11=Rd and Rs1
pc auipc) xZERO rd) 0 imm) ,) \ insert 31:12 bits
   jalr) xZERO xZERO 0 3p) ,) \ insert 11:0 bits
   jal) xZERO 0 2p) ,)        \ insert 20:1 bits
xcode relcall, ( dstreg rel -- )
  srai) x10 xW 20 3p) ,)
  addi) x10 x10 1 3p) ,)
  andi) x10 x10 -2 3p) ,)
  x11 ppop,
  forward8 [jmp] bnez) x10 rs1) ,)
    ( pc a ) over 8 + x10 pc@>reg,
    slli) x11 x11 7 3p) ,)
    or) x10 x10 x11 3p) ,)
    lblJimm abscall,
    wjmp, ,
  forward!
  ( pc ) dup x10 pc@>reg,
  slli) x19 x11 7 3p) ,)
  or) x10 x10 x19 3p) ,)
  x11 push,
  xdup, wcall, hibits
  lblUimm abscall,
  lbldwrite abscall,
  ( pc ) 4 + x10 pc@>reg,
  x11 pop,
  slli) x19 x11 7 3p) ,)
  or) x10 x10 x19 3p) ,)
  slli) x19 x11 15 3p) ,)
  or) x10 x10 x19 3p) ,)
  x10 ppush,
  wcall, Iimm!
  wjmp, ,

xcode call, ( w -- )
  x11 x12 HERE@,
  sub) xW xW x11 3p) ,)
  x11 xRA li, x11 ppush,
  wjmp, relcall,

pc xdup,
xcode litn
  ( pc ) x10 pc'>reg, x11 8 li, lblwriterange abscall,
  x11 xW li, x11 ppush,
  wjmp, imm,

\ Interpret loop
xcode stack?
  ret, ret, \ make it take 2 instrs slot because it will be realiased later

pc to L1 ( -- e ) \ x10=str. find in sys dict
  xdup, x10 ppush,
  lw) xW xSYSVARS oSYSDICT 3p) ,)
  wcall, findentry
  forward8 [jmp] bne) xW xZERO 2p) ,)
    xwordlbl (wnf) absb,
  forward!
  ret,

pc to L2 ( w -- ) \ execute
  wcall, execute
  wjmp, stack?

pc to L4 ( str -- )
  xW push, wcall, parse x10 pop, \ x10=str
  mv) x19 xW 2p) ,)
  xdrop,
  bne) x19 xZERO 2p) xwordlbl litn abs>rel imm) ,)
  L1 abscall,
  mv) x18 xW 2p) ,) \ x18=e
  addi) xW xW 4 3p) ,)
  lbu) x10 x18 -1 3p) ,)
  andi) x19 x10 $40 3p) ,)
  forward8 [jmp] beq) x19 xZERO 2p) ,)
    x19 1 li,
    sw) x19 xSYSVARS oFINDCOMPILER 3p) ,)
    x18 ppush, L2 abscall, x18 ppop, forward!
  sw) xZERO xSYSVARS oFINDCOMPILER 3p) ,)
  lbu) x10 x18 -1 3p) ,)
  andi) x19 x10 $80 3p) ,)
  bne) x19 xZERO L2 abs>rel 3p) ,) \ immediate? execute
  \ compile word
  wjmp, call,

xcode ]
  x10 1 li,
  sw) x10 xSYSVARS oCOMPILING 3p) ,)
pc
  wcall, word
  L4 abscall,
  lw) x10 xSYSVARS oCOMPILING 3p) ,)
  ( pc ) bne) x10 rs1) xZERO rs2) swap abs>rel imm) ,)
  ret,

xcode run1 ( -- )
  wcall, word
  xW push, wcall, parse x10 pop,
  mv) x19 xW 2p) ,)
  xdrop,
  forward8 [jmp] beq) x19 xZERO 2p) ,)
    ret, forward!
  L1 abscall,
  sw) xZERO xSYSVARS oFINDCOMPILER 3p) ,)
  mv) x18 xW 2p) ,) \ x18=e
  addi) xW xW 4 3p) ,)
  lbu) x10 x18 -1 3p) ,)
  andi) x19 x10 $40 3p) ,)
  forward8 [jmp] beq) x19 xZERO 2p) ,)
    x18 ppush, L2 abscall, x18 ppop, forward!
  L2 absb,

xcode :
  wcall, code
  wcall, pushlr,
  wjmp, ]

xcode [ ximm
  sw) xZERO xSYSVARS oCOMPILING 3p) ,)
  ret,

xcode ; ximm
  sw) xZERO xSYSVARS oCOMPILING 3p) ,)
  wjmp, popexit,

xcode SYSVARS xdup, mv) xW xSYSVARS 2p) ,) ret,

xcode main
  lw) xRSP xSYSVARS oRSORIGIN 3p) ,)
pc
  wcall, run1
  ( pc ) j) swap abs>rel imm) ,)

pc to lblbaseboot
  lw) xPSP xSYSVARS oPSORIGIN 3p) ,)
  wjmp, main
\ kernelend is called in target-specific kernels