mb4.deck

{deck}
version:1
card:0
size:[512,342]
name:"mb4.deck"

{card:home}

{module:mb4}
description:"the b4 virtual machine"
{script}

echo:print

on ord c do first "%a" parse c end
mod.reg: on reg c do 4*ord[c]-64 end
# get/set registers
mod.sr: on _sr c v do _wi[reg[c] v] end
mod.gr: on _gr c v do _ri[reg[c]] end

HERE:reg["_"]    # where the assembler will write data next
THERE:reg["\\"]  # temp var when writing to specific address
LAST:reg["^"]    # used for dictionary

MEMSIZE: 4096*4 # in bytes

# private registers
p:32 on pr do p:p+1 end
RMZ:pr[] # memory size
RIP:pr[] # instruction pointer
RDA:pr[] # ds address
RDS:pr[] # ds height
RDZ:pr[] # ds size (max height)
RCA:pr[] # cs address
RCS:pr[] # cs height
RCZ:pr[] # cs size (max height)
RST:pr[] # state flag
RDB:pr[] # debug flag
RED:pr[] # "edit pointer" (used by memory browsing ui)
if p>64 panic["too many registers!"] end

PAGE:4096
on mk_rg mem do rg: mem.slice[0,64*4] rg.cast:"i32l" rg end
on new cfg do
  mem:array[mz:if t:cfg.mz t else PAGE*4 end "u8"]
  rg:mk_rg[mem]
  rg[RMZ]:mz
  rg[RIP]:if t:cfg.ip t else    256 end
  rg[RDA]:if t:cfg.da t else PAGE*2 end # default ds at $2000
  rg[RDZ]:if t:cfg.dz t else   1024 end
  rg[RDS]:0
  rg[RCA]:if t:cfg.ca t else PAGE*3 end # default cs at $3000
  rg[RCZ]:if t:cfg.cz t else   1024 end
  rg[RCS]:0
  r.mem:mem
  r.rg:rg
  # !! small bug in lil 1.4.2 when slice cast is different, so we have to
  #    set it separately and 4* the size. should be fixed in next version.
  r.vb:mem.slice[4096,4096]    # 64x16x4 video buffer at $10000
  r.ds:mem.slice[r.rg[RDA],r.rg[RDZ]*4] r.ds.cast:"i32l"
  r.cs:mem.slice[r.rg[RCA],r.rg[RCZ]*4] r.cs.cast:"i32l"
  r
end

# all functions close over global variable vm.
# the entire state of a CPU is stored in vm.mem
# this way, we can swap out different vms easily
# just by replacing vm.mem.
vm:new[]
labels:()dict()

mod.ri: on _ri a do vm.mem.here:a vm.mem.struct["i32l"] end
mod.wi: on _wi a v do vm.mem.here:a vm.mem.struct["i32l" v] end

mod.clear: on clear do
  vm:new[]
  mod.wi[HERE 256]
  labels:()dict()
  vm.ob:()
end
mod.reset: on reset do
  vm.rg[RIP]:256
  vm.rg[RDS]:0
  vm.rg[RCS]:0
  vm.rg[RVW]:4
  vm.rg[RST]:0
end
clear[] reset[]

on fail msg do
  echo["!!: ", msg]
  echo[showIp[]]
  echo[showStack.ds]
  echo[showStack.cs]
  panic[msg]
end

on dpop do
  if 0<i:vm.rg[RDS] r:vm.ds[i-1] vm.rg[RDS]:i-1 r
  else fail["dpop: underflow"] end end
on cpop do
  if 0<i:vm.rg[RCS] r:vm.cs[i-1] vm.rg[RCS]:i-1 r
  else fail["cpop: underflow"] end end

on dget x do
  if 0<i:vm.rg[RDS]-x vm.ds[i-1]
  else fail["dget: underflow"] end end
on dtos do dget[0] end
on dput x do
  if vm.rg[RDZ]>i:vm.rg[RDS] vm.ds[i]:x vm.rg[RDS]:i+1
  else fail["dput: overflow"] end end
on cput x do
  if vm.rg[RCZ]>i:vm.rg[RCS] vm.cs[i]:x vm.rg[RCS]:i+1
  else fail["cput: overflow"] end end

on dpop2 do r:dpop[] dpop[],r end
mod.showStack: on showStack xs do
  vs: if xs~"cs" vm.cs[0,vm.rg[RCS]] else vm.ds[0,vm.rg[RDS]] end
  "%s: [%s]" format xs,(" " fuse toHex @ vs) end


on here x do if x _wi[HERE x] else _ri[HERE] end end
on there x do if x _wi[THERE x] else _ri[THERE] end end

op.ad: on ad do dput[sum dpop2[]] end
op.ml: on ml do dput[dpop[] * dpop[]] end
op.sb: on sb do y:dpop[] dput[dpop[]-y] end
op.dv: on dv do y:dpop[] dput[floor dpop[]/y] end
op.md: on md do dput[dpop[] % dpop[]] end # !!
op.sh: on sh do y:2^dpop[] dput[floor dpop[]*y] end
op.an: on an do dput[bits.and[dpop[] dpop[]]] end
op.or: on or do dput[bits.or[dpop[] dpop[]]] end
op.xr: on xr do dput[bits.xor[dpop[] dpop[]]] end
op.nt: on nt do dput[-1-dpop[]] end
op.zp: on zp do dpop[] end
op.eq: on eq do dput[-(dpop[] = dpop[])] end
op.lt: on lt do y:dpop[] dput[-(dpop[]<y)] end
op.du: on du do dput[dtos[]] end
op.sw: on sw do y:dpop[] x:dpop[] dput[y] dput[x]end
op.ov: on ov do dput[dget[1]] end
op.dc: on dc do t:dpop[] cput[t] end
op.cd: on cd do t:cpop[] dput[t] end


op.rb: on rb do dput[vm.mem[dpop[]]] end
op.ri: on ri do dput[_ri[dpop[]]] end
op.wb: on wb do vm.mem[dpop[]]: dpop[] end
op.wi: on wi do a:dpop[] v:dpop[] _wi[a v] end
op.c0: on c0 do dput[0] end
op.c1: on c1 do dput[1] end
op.rr: on rr r do dput[_ri[r]] end
op.ir: on ir r do v:_ri[r] t:dpop[] _wi[r v+t] dput[v] end
op.wr: on wr r do v:dpop[] _wi[r v] end
op.er: on er r do cput[vm.rg[RIP]+1] _goto[_ri[r]] end

op.lb: on lb do vm.rg[RIP]:vm.rg[RIP]+1 dput[vm.mem[vm.rg[RIP]]] end
op.li: on li do dput[_ri[vm.rg[RIP]+1]] vm.rg[RIP]: vm.rg[RIP]+4 end

# signed bytes
on short b do if b > 127 b-256 else b end end
op.ls: on ls do vm.rg[RIP]:vm.rg[RIP]+1 dput[short[vm.mem[vm.rg[RIP]]]] end
op.rs: on rs do dput[short[vm.mem[dpop[]]]] end

mod.goto: on _goto a do vm.rg[RIP]:(max 256,a)-1 end
on _hop do
  vm.mem.cast:"i8"
  _goto[vm.rg[RIP]+vm.mem[vm.rg[RIP]+1]]
  vm.mem.cast:"u8"
end
op.hp: on hp do _hop[] end
op.h0: on h0 do if dpop[] vm.rg[RIP]:vm.rg[RIP]+1 else _hop[] end end
op.jm: on jm do _goto[_ri[vm.rg[RIP]+1]] end
op.cl: on cl do cput[vm.rg[RIP]+5] _goto[_ri[vm.rg[RIP]+1]] end
op.rt: on rt do if !a:cpop[] vm.rg[RST]:0 else _goto[a] end end
op.nx: on nx do
  if 0<i:cpop[]-1  cput[i] _hop[] else vm.rg[RIP]:vm.rg[RIP]+1 end
end

op.io: on io do
  m: "%a" format dpop[] # vm.mem[vm.rg[RIP]:vm.rg[RIP]+1]
  if m~"e" x:dpop[] vm.ob:vm.ob,("%a" format x)
  elseif m="R"
  else echo["no: io '",m] end
end

op.hl: on hl do vm.rg[RST]:1-vm.rg[RST] end
op.db: on db do vm.rg[RST]:0 vm.rg[RDB]:1 end

#--- canvas stuff

cvi.b: on cvib cv do wh:dpop2[] xy:dpop2[] cv.box[xy wh] end   # box (hollow)
cvi.c: on cvic cv do dput[180] cvi.n[cv] end                   # circle (xyr-)
cvi.d: on cvid cv do s:cv.size dput[s[0]] dput[s[1]] end       # query dimensions
cvi.f: on cvif cv do cv.pattern: x:dpop[] end                  # fill
cvi.l: on cvil cv do p1:dpop2[] cv.line[dpop[], p1] end        # line(p0p1-)
cvi.n: on cvin cv do n:dpop[] r:dpop[] xy:dpop2[]              # n-gon (xyrn-)
  a: 2*pi * (range n)/n  a:a,1 take a
  cv.poly[flip floor 0.5+xy+r*(list cos a),list sin a]
end
cvi.r: on cvir cv do wh:dpop2[] xy:dpop2[] cv.rect[xy wh] end  # rect (filled)
cvi.s: on cvis cv do cv.brush: x:dpop[] end                    # stroke
op.cv: on cv do
  if mod.cv m:"%a" format dpop[]
    if m in cvi cvi[m][mod.cv]
    else echo["cv.no: '",m] end
  else echo["no cv!"] end
end

#--- terminal

mod.tm:0
op.tm: on tm do
  if mod.tm mod.tm.op["%a" format dpop[]][]
  else fail["tm: no terminal device!"] end
end


# ---------------------

on toHex n do  if n < 0 "-%H" format -n else "%H" format n end end
on isHex s do "%*.1o-%*.16r0123456789ABCDEF%z" parse s end
on unHex s do  p: "%.1o-%H" parse s  if p[0] 0-p[1] else p[1] end end


mod.regop: on regop x do
  _c: "%[cmd]1.7o+`^!@:?"
  _r: "%[reg]1.32o@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
  _p: "" fuse _c,_r,"%[m]z" (_p parse x).m
end
# assert (1,1,0,0,0,1) regop@("@y","'C","`3",">>","`no","`Y")

#'* '! '\" '# '$ '% '& '' '( ') '* '+ ', '- '. '/
#'0 '1 '2 '3 '4 '5 '6 '7 '8 '9 ': '; '< '= '> '?
#'@ 'A 'B 'C 'D 'E 'F 'G 'H 'I 'J 'K 'L 'M 'N 'O
#'P 'Q 'R 'S 'T 'U 'V 'W 'X 'Y 'Z '[ '\\ '] '^ '_
#'` 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o
#'p 'q 'r 's 't 'u 'v 'w 'x 'y 'z '{ '| '} '~ ^?

TBL:
".. ^A ^B ^C ^D ^E ^F ^G ^H ^I ^J ^K ^L ^M ^N ^O
^P ^Q ^R ^S ^T ^U ^V ^W ^X ^Y ^Z ^[ ^\\ ^] ^^ ^_
@@ @A @B @C @D @E @F @G @H @I @J @K @L @M @N @O
@P @Q @R @S @T @U @V @W @X @Y @Z @[ @\\ @] @^ @_
!@ !A !B !C !D !E !F !G !H !I !J !K !L !M !N !O
!P !Q !R !S !T !U !V !W !X !Y !Z ![ !\\ !] !^ !_
+@ +A +B +C +D +E +F +G +H +I +J +K +L +M +N +O
+P +Q +R +S +T +U +V +W +X +Y +Z +[ +\\ +] +^ +_
ad sb ml dv md sh an or xr nt eq lt du sw ov zp
dc cd rb ri wb wi lb li rs ls jm hp h0 cl rt nx
A0 A1 A2 A3 A4 A5 A6 A7 A8 A9 AA AB AC AD AE AF
B0 B1 B2 B3 B4 B5 B6 B7 B8 B9 BA BB BC BD tm cv
c0 c1 C2 C3 C4 C5 C6 C7 C8 C9 CA CB CC CD CE CF
D0 D1 D2 D3 D4 D5 D6 D7 D8 D9 DA DB DC DD DE DF
E0 E1 E2 E3 E4 E5 E6 E7 E8 E9 EA EB EC ED EE EF
F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 FA FB FC io db hl"
TBL: " " split " " fuse "\n" split TBL
TBL:select op:index code:value from TBL


mod.dis: on dis i do first extract code where op=i from TBL end
mod.disa: on disa i do
  if (i<127)&(i>31) "'%a" format i
  elseif i=127 "^?"
  else first extract code where op=i from TBL end end
mod.asm: on asm x do
  if r: extract op where code=x from TBL r
  elseif x[0]="'" x[1]
  else unHex[x] end
end

mod.step: on step do
  c:dis[o:vm.mem[vm.rg[RIP]]]
  # echo["%i %4H %s" format vm.rg[RST], vm.rg[RIP], c]
  if c in op op[c][]
  elseif c=".." # ok
  else r:reg[c[1]]
    if c[0]="^" op.er[r]
    elseif c[0]="@" op.rr[r]
    elseif c[0]="!" op.wr[r]
    elseif c[0]="+" op.ir[r]
    else  echo["step->",c,"(ignored)"] end
  end
  vm.rg[RIP]: vm.rg[RIP]+1
end

RT: first extract op where code="rt" from TBL
mod.run: on run do vm.rg[RST]:1 while vm.rg[RST]=1 step[] end end
mod.runToEnd: on runToEnd di do
  vm.rg[RST]: 1
  while (vm.rg[RST]=1) & (!vm.mem[vm.rg[RIP]]=RT) step[] end step[]
  vm.rg[RIP]: vm.rg[RIP]+di # so op.er can not inc ip
end

mod.showMem: on showMem a do " " fuse dis @ vm.mem @ a + range 16 end
mod.showMemA: on showMemA a do " " fuse disa @ vm.mem @ a + range 16 end
mod.showIp: on showIp do "ip: %02H" format vm.rg[RIP] end
on assemble a s do n:count toks:" "split s  vm.mem[a,n]:raze asm@toks n end
on asm_via hp s do a:_ri[hp]  n:assemble[a s] _wi[hp a+n] end

mod.exec: on im_run a do # immediately run word at address a (for b4i)
  cput[vm.rg[RIP]] cput[0] _goto[a+1] run[] ip:cpop[] vm.rg[RIP]:ip
end

mod.b4i: on b4i line do
  toks: extract value where value from " " split line
  state:IMM:0 ASM:1 CMT:2    hp:HERE # may be THERE later
  quit:0
  each tok in toks  t:tok[0]
    if (state=CMT) | (t="#") state:CMT
    elseif regop[tok] r:reg[c:tok[1]]
      if t="?" echo["%08H" format _ri[r]]
      elseif t=":" state:ASM _wi[r _ri[hp]]
        if c="\\" _goto[_gr["\\"]+1] end
      elseif state=ASM
        asm_via[hp if t="`" "lb ^%s" format c else tok end]
      elseif t="`" dput[r]
      elseif t="!" op.wr[r]
      elseif t="@" op.rr[r]
      elseif t="+" op.ir[r]
      elseif t="^" im_run[_ri[r]]
      else echo["regop.no: ",tok] end
    elseif t="%"
      if     tok="%q" quit:1 stote:CMT
      elseif tok="%R" reset[]
      elseif tok="%C" clear[]
      elseif tok="%s" step[]
      elseif tok="%e" runToEnd[]
      elseif tok="%\\" _goto[_gr["\\"]+1]
      else echo["%.no: ",tok] end
    elseif t="?"
      if tok="?i" echo[showIp[]]
      elseif tok="?d" echo[showStack["ds"]]
      elseif tok="?c" echo[showStack["cs"]]
      else hex: "?%[q].1oa%[a]H%[m]z" parse tok
        if hex.m echo[(if hex.q showMemA else showMem end)[hex.a]]
        elseif (nm:1 drop tok) in labels
          echo[":%04h %s" format labels[nm],showMem[labels[nm]]]
        else echo["?.no: ",tok] end
      end
    elseif t="$"
      if (nm:1 drop tok) in labels
        v:labels[nm] if state=ASM
          a:_ri[hp] _wi[a v] _wi[hp a+4] # !!same as 'ei[v]' in `macro`
        else dput[v] end
      else echo["$.no: ",tok] end
    elseif t=":"
      state:ASM hp:HERE c:tok[1]
      if tok="::" # ok
      elseif 2=count tok echo[":.no: ", tok] # because it's 2 chars but not regop
      elseif tok=":" echo["no: :"]
      elseif isHex[a:1 drop tok]  _wi[hp:THERE unHex[a]]
      else labels[1 drop tok]: _ri[hp] end
    elseif t="'"
      v: if tok="'" 32 else ord[tok[1]] end
      if state=ASM asm_via[hp tok]
      else dput[v] end
    elseif t="." macro[hp tok[1]]
    elseif tok in op
      # '..' executes as no-op. if you want to push 0, type '00'
      if state=ASM asm_via[hp tok] else op[tok][] end
    elseif tok=".."
      if state=ASM asm_via[hp tok] end
    elseif isHex[tok]
      if state=ASM asm_via[hp tok] else dput[unHex[tok]] end
    elseif tok in labels a:labels[tok]
      if state=ASM asm_call[hp a] else im_run[a] end
    elseif (t in "`@!+") & (k:1 drop tok) in labels  lk:labels[k]
      if t="`"
        if state=ASM asm_int[hp lk] else dput[lk] end
      elseif t="@"
        if state=ASM asm_get[hp lk] else dput[lk] op.ri[] end
      elseif t="!"
        if state=ASM asm_set[hp lk] else dput[lk] op.wi[] end
      elseif t="+"
        if state=ASM asm_inc[hp lk] else echo["nyi: +label"] end
      end
    else echo["no: %s" format tok] end
  end
  if vm.ob echo[vm.ob] vm.ob:() end
  if quit if deck reset[] else mod.exit[0] end end
end

on asm_int hp i do a:_ri[hp] _wi[a i] _wi[hp a+4] end
on asm_get hp a do asm_via[hp "li"] asm_int[hp a] asm_via[hp "ri"] end
on asm_set hp a do asm_via[hp "li"] asm_int[hp a] asm_via[hp "wi"] end
on asm_inc hp a do asm_via[hp "li"] asm_int[hp a]
   # (d)elta,(a)ddr = da -> ada      > adv|v   > aV|v  > v
   asm_via[hp               "sw ov   ri du dc    ad    sw wi cd"] end
on asm_call hp a do asm_via[hp "cl"] asm_int[hp a] end

on macro hp c do
  on m c do macro[hp c] end
  on a s do asm_via[hp s] end
  on to a do slot:dpop[] dist:(a-slot)+1
    if dist <0 echo["invalid forward hop"]
    elseif dist > 126 echo["hop too far. dist:",dist]
    else vm.mem[slot]: dist end
  end
  on hr do _ri[hp] end                              # hr: "here"
  on hh do to[hr[]] end                             # hh: "hop here"
  on bk do dist:dpop[]-hr[] eb[dist+1] end          # bk: "back"
  on eb x do a:hr[] vm.mem[a]:x _wi[hp a+1] end     # eb: "emit byte"
  on ei x do a:hr[] _wi[a x] _wi[hp a+4] end        # ei: "emit int"
  if     c="." a[".."]
  elseif c="_" dput[hr[]] a[".."]  # emit 0, leaving address on stack
  # -- if/else/then:  cond .i if-body .e el-body .t
  elseif c="i" a["h0"] m["_"]
  elseif c="e" a["hp"] m["_"] op.sw[] hh[]
  elseif c="t" hh[]
  # -- while loops:  .w cond .d body .z
  elseif c="w" dput[hr[]]
  elseif c="d" a["h0"] m["_"] # same as .i
  elseif c="z" a["hp"] op.sw[] bk[] hh[]  # hop back to .w, and tell .d where to exit
  elseif c="o" a["hp"] op.sw[] bk[] hh[]  # .o was old word for .z
  # -- for/next:
  elseif c="f" a["dc"] dput[hr[]]
  elseif c="n" a["nx"] bk[]
  # -- list builder:
  elseif c="^" a:hr[] ei[_gr["^"]] _sr["^" a]
  # -- otherwise:
  else echo[".no: ",c] end
end

# put/pop used by terminal device
mod.dput: dput
mod.dpop: dpop
mod.get_labels: on get_labels do labels end
mod.echo: on echo line do mod.echo[line] end
mod.set_cv: on set_cv cv do mod.cv: cv end
mod.set_tm: on set_tm tm do mod.tm: tm end
mod.set_echo: on set_echo fn do mod.echo: fn end
mod.TBL: TBL
mod.get_vm:on get_vm do vm end
mod.get_ip:on get_ip do vm.rg[RIP] end  mod.set_ip:on set_ip a do vm.rg[RIP]:a end
mod.get_ed:on get_ed do vm.rg[RED] end  mod.set_ed:on set_ed a do vm.rg[RED]:a end
mod.get_st:on get_st do vm.rg[RST] end  mod.set_st:on set_st a do vm.rg[RST]:a end
mod.get_db:on get_db do vm.rg[RDB] end  mod.set_db:on set_db a do vm.rg[RDB]:a end
mod.exit:exit # but this is probably not defined yet
mod.set_exit: on set_exit f do mod.exit:f end
{end}