Files
wipforth/wipforth.wat

1073 lines
20 KiB
Plaintext

;; Don't panic! WAT's just like assembly, really -- if you're missing macros,
;; labels and jumps.
(module
(import "emu" "mem" (memory 1 1 shared))
;; Peripheral registers
(global $TXBUF i32 (i32.const 0x0000))
(global $RXBUF i32 (i32.const 0x0020))
(global $TXHEAD i32 (i32.const 0x0040))
(global $TXTAIL i32 (i32.const 0x0041))
(global $RXHEAD i32 (i32.const 0x0042))
(global $RXTAIL i32 (i32.const 0x0043))
;; Forth registers
(global $rsp (mut i32) (i32.const 0))
(global $sp (mut i32) (i32.const 0))
(global $ip (mut i32) (i32.const 0))
(global $cfa (mut i32) (i32.const 0))
(global $fn (mut i32) (i32.const 0))
;; Some little helper functions
(func $push (param $x i32)
global.get $sp
i32.const 4
i32.sub
global.set $sp
global.get $sp
local.get $x
i32.store)
(func $pop (result i32)
global.get $sp
i32.load
global.get $sp
i32.const 4
i32.add
global.set $sp)
(func $pushrsp (param $x i32)
global.get $rsp
i32.const 4
i32.sub
global.set $rsp
global.get $rsp
local.get $x
i32.store)
(func $poprsp (result i32)
global.get $rsp
i32.load
global.get $rsp
i32.const 4
i32.add
global.set $rsp)
;; The rather bizzare nature of WebAssembly means that we can't
;; actually jump to code, which makes this NEXT implemenation
;; somewhat strange. Instead of doing the jump here, we store the
;; function index (seemingly the closest you can get to a code
;; address in WebAssembly) in the $fn global and return. It's then
;; down to the $trampoline loop to actually run the codeword.
(func $next
global.get $ip
global.get $ip
i32.const 4
i32.add
global.set $ip
i32.load
global.set $cfa
global.get $cfa
i32.load
global.set $fn)
;; Our special inner interpreters <3
(func $docol
global.get $ip
call $pushrsp
global.get $cfa
i32.const 4
i32.add
global.set $ip
call $next)
(func $doconst
global.get $cfa
i32.const 4
i32.add
i32.load
call $push
call $next)
(func $dovar
global.get $cfa
i32.const 4
i32.add
call $push
call $next)
;; Codewords!
;;
;; Most of these are implemented here (as opposed to in the forth
;; itself) for performance rather than necessity.
;; Stack manipulation
(func $dup
global.get $sp
i32.load
call $push
call $next)
(func $drop
global.get $sp
i32.const 4
i32.add
global.set $sp
call $next)
(func $swap
global.get $sp
i32.const 4
i32.add
global.get $sp
i32.load
global.get $sp
global.get $sp
i32.const 4
i32.add
i32.load
i32.store
i32.store
call $next)
(func $rot
global.get $sp
i32.const 4
i32.add
global.get $sp
i32.load
global.get $sp
i32.const 8
i32.add
global.get $sp
i32.const 4
i32.add
i32.load
global.get $sp
global.get $sp
i32.const 8
i32.add
i32.load
i32.store
i32.store
i32.store
call $next)
(func $nrot
global.get $sp
i32.const 8
i32.add
global.get $sp
i32.load
global.get $sp
global.get $sp
i32.const 4
i32.add
i32.load
global.get $sp
i32.const 4
i32.add
global.get $sp
i32.const 8
i32.add
i32.load
i32.store
i32.store
i32.store
call $next)
(func $over
global.get $sp
i32.const 4
i32.add
i32.load
call $push
call $next)
(func $twodup
global.get $sp
i32.load
global.get $sp
i32.const 4
i32.sub
i32.load
call $push
call $push
call $next)
(func $twodrop
global.get $sp
i32.const 8
i32.add
global.set $sp
call $next)
(func $twoswap
global.get $sp
i32.const 8
i32.add
global.get $sp
i32.load
global.get $sp
i32.const 12
i32.add
global.get $sp
i32.const 4
i32.add
i32.load
global.get $sp
global.get $sp
i32.const 8
i32.add
i32.load
global.get $sp
i32.const 4
i32.add
global.get $sp
i32.const 12
i32.add
i32.load
i32.store
i32.store
i32.store
i32.store
call $next)
;; Arithmetic and logic
(func $inc
global.get $sp
global.get $sp
i32.load
i32.const 1
i32.add
i32.store
call $next)
(func $dec
global.get $sp
global.get $sp
i32.load
i32.const 1
i32.sub
i32.store
call $next)
(func $inc4
global.get $sp
global.get $sp
i32.load
i32.const 4
i32.add
i32.store
call $next)
(func $dec4
global.get $sp
global.get $sp
i32.load
i32.const 4
i32.sub
i32.store
call $next)
(func $add
call $pop
call $pop
i32.add
call $push
call $next)
(func $sub (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.sub
call $push
call $next)
(func $mul
call $pop
call $pop
i32.mul
call $push
call $next)
(func $div (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.div_s
call $push
call $next)
(func $mod (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.rem_s
call $push
call $next)
(func $eq
call $pop
call $pop
i32.eq
call $push
call $next)
(func $neq
call $pop
call $pop
i32.ne
call $push
call $next)
(func $lt (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.lt_s
call $push
call $next)
(func $gt (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.gt_s
call $push
call $next)
(func $lte (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.le_s
call $push
call $next)
(func $gte (local $tmp i32)
call $pop
local.set $tmp
call $pop
local.get $tmp
i32.ge_s
call $push
call $next)
(func $zeq
call $pop
i32.eqz
call $push
call $next)
(func $zneq
call $pop
i32.const 0
i32.ne
call $push
call $next)
(func $zlt
call $pop
i32.const 0
i32.lt_s
call $push
call $next)
(func $zgt
call $pop
i32.const 0
i32.gt_s
call $push
call $next)
(func $zlte
call $pop
i32.const 0
i32.le_s
call $push
call $next)
(func $zgte
call $pop
i32.const 0
i32.ge_s
call $push
call $next)
(func $and
call $pop
call $pop
i32.and
call $push
call $next)
(func $or
call $pop
call $pop
i32.or
call $push
call $next)
(func $xor
call $pop
call $pop
i32.xor
call $push
call $next)
(func $invert
call $pop
i32.const 0xffffffff
i32.xor
call $push
call $next)
;; Memory
(func $store
call $pop
call $pop
i32.store
call $next)
(func $fetch
call $pop
i32.load
call $push
call $next)
(func $addstore (local $tmp i32)
call $pop
local.tee $tmp
local.get $tmp
i32.load
call $pop
i32.add
i32.store
call $next)
(func $substore (local $tmp i32)
call $pop
local.tee $tmp
local.get $tmp
i32.load
call $pop
i32.sub
i32.store
call $next)
(func $storebyte
call $pop
call $pop
i32.store8
call $next)
(func $fetchbyte
call $pop
i32.load8_u
call $push
call $next)
;; Core utility words
(func $exit
call $poprsp
global.set $ip
call $next)
(func $lit
global.get $ip
i32.load
call $push
global.get $ip
i32.const 4
i32.add
global.set $ip
call $next)
;; Return and parameter stack primitives
(func $tor
call $pop
call $pushrsp
call $next)
(func $fromr
call $poprsp
call $push
call $next)
(func $rspfetch
global.get $rsp
call $push
call $next)
(func $rspstore
call $pop
global.set $rsp
call $next)
(func $rdrop
global.get $rsp
i32.const 4
i32.add
global.set $rsp
call $next)
(func $spfetch
global.get $sp
call $push
call $next)
(func $spstore
call $pop
global.set $sp
call $next)
;; Serial I/O
(func $key (local $head i32)
;; Wait for RXBUF to be non-empty
loop $wait
global.get $RXHEAD
i32.atomic.load8_u
local.tee $head
global.get $RXTAIL
i32.atomic.load8_u
i32.eq
br_if $wait
end
;; Read byte at head position
global.get $RXBUF
local.get $head
i32.add
i32.load8_u
call $push
;; Advance RXHEAD
global.get $RXHEAD
local.get $head
i32.const 1
i32.add
i32.const 0x1f
i32.and
i32.atomic.store8
call $next)
(func $emit (local $tail i32) (local $next i32)
;; Wait for TXBUF to be non-full
loop $wait
global.get $TXTAIL
i32.atomic.load8_u
local.tee $tail
i32.const 1
i32.add
i32.const 0x1f
i32.and
local.tee $next
global.get $TXHEAD
i32.atomic.load8_u
i32.eq
br_if $wait
end
;; Write byte at tail position
global.get $TXBUF
local.get $tail
i32.add
call $pop
i32.store8
;; Advance TXTAIL
global.get $TXTAIL
local.get $next
i32.atomic.store8
call $next)
;; Branching
(func $branch
global.get $ip
i32.load
global.get $ip
i32.add
global.set $ip
call $next)
(func $zbranch
call $pop
if (result i32)
global.get $ip
i32.load
else
i32.const 4
end
global.get $ip
i32.add
global.set $ip
call $next)
;; The codewords function table must contain every codeword we want
;; to be able to run, as it's indices into this table that can be ran
;; with call_indirect in the $trampoline loop. Fantastically, there
;; doesn't seem to be a way to sensibly give symbolic names to the
;; indices the functions are inserted at so, instead of having all
;; the entries here, most of them are defined in-line with the
;; dictionary entries so that the definition of the index isn't too
;; far from its use.
;;
;; The exceptions are the special inner interpreters, DOCOL, DOCONST
;; and DOVAR, which I've put here in indices 0, 1 and 2 for
;; convenience.
(type $codeword (func))
(table $codewords 100 funcref)
(elem (i32.const 0x00) $docol)
(elem (i32.const 0x01) $doconst)
(elem (i32.const 0x02) $dovar)
;; Dictionary time D:
;;
;; I <3 writing dictionary entries by hand!
(elem (i32.const 0x03) $dup)
(data (i32.const 0x0200)
"\00\00\00\00"
"\03DUP"
"\03\00\00\00")
(elem (i32.const 0x04) $drop)
(data (i32.const 0x020c)
"\00\02\00\00"
"\04DROP\00\00\00"
"\04\00\00\00")
(elem (i32.const 0x05) $swap)
(data (i32.const 0x021c)
"\0c\02\00\00"
"\04SWAP\00\00\00"
"\05\00\00\00")
(elem (i32.const 0x06) $rot)
(data (i32.const 0x022c)
"\1c\02\00\00"
"\03ROT"
"\06\00\00\00")
(elem (i32.const 0x07) $nrot)
(data (i32.const 0x0238)
"\2c\02\00\00"
"\04-ROT\00\00\00"
"\07\00\00\00")
(elem (i32.const 0x08) $over)
(data (i32.const 0x0248)
"\38\02\00\00"
"\04OVER\00\00\00"
"\08\00\00\00")
(elem (i32.const 0x09) $twodup)
(data (i32.const 0x0258)
"\48\02\00\00"
"\042DUP\00\00\00"
"\09\00\00\00")
(elem (i32.const 0x0a) $twodrop)
(data (i32.const 0x0268)
"\58\02\00\00"
"\052DROP\00\00"
"\0a\00\00\00")
(elem (i32.const 0x0b) $twoswap)
(data (i32.const 0x0278)
"\68\02\00\00"
"\052SWAP\00\00"
"\0b\00\00\00")
(elem (i32.const 0x0c) $inc)
(data (i32.const 0x0288)
"\78\02\00\00"
"\021+\00"
"\0c\00\00\00")
(elem (i32.const 0x0d) $dec)
(data (i32.const 0x0294)
"\88\02\00\00"
"\021-\00"
"\0d\00\00\00")
(elem (i32.const 0x0e) $inc4)
(data (i32.const 0x02a0)
"\94\02\00\00"
"\024+\00"
"\0e\00\00\00")
(elem (i32.const 0x0f) $dec4)
(data (i32.const 0x02ac)
"\a0\02\00\00"
"\024-\00"
"\0f\00\00\00")
(elem (i32.const 0x10) $add)
(data (i32.const 0x02b8)
"\ac\02\00\00"
"\01+\00\00"
"\10\00\00\00")
(elem (i32.const 0x11) $sub)
(data (i32.const 0x02c4)
"\b8\02\00\00"
"\01-\00\00"
"\11\00\00\00")
(elem (i32.const 0x12) $mul)
(data (i32.const 0x02d0)
"\c4\02\00\00"
"\01*\00\00"
"\12\00\00\00")
(elem (i32.const 0x13) $div)
(data (i32.const 0x02dc)
"\d0\02\00\00"
"\01/\00\00"
"\13\00\00\00")
(elem (i32.const 0x14) $mod)
(data (i32.const 0x02e8)
"\dc\02\00\00"
"\03MOD"
"\14\00\00\00")
(elem (i32.const 0x15) $eq)
(data (i32.const 0x02f4)
"\e8\02\00\00"
"\01=\00\00"
"\15\00\00\00")
(elem (i32.const 0x16) $neq)
(data (i32.const 0x0300)
"\f4\02\00\00"
"\02<>\00"
"\16\00\00\00")
(elem (i32.const 0x17) $lt)
(data (i32.const 0x030c)
"\00\03\00\00"
"\01<\00\00"
"\17\00\00\00")
(elem (i32.const 0x18) $gt)
(data (i32.const 0x0318)
"\0c\03\00\00"
"\01>\00\00"
"\18\00\00\00")
(elem (i32.const 0x19) $lte)
(data (i32.const 0x0324)
"\18\03\00\00"
"\02<=\00"
"\19\00\00\00")
(elem (i32.const 0x1a) $gte)
(data (i32.const 0x0330)
"\24\03\00\00"
"\02>=\00"
"\1a\00\00\00")
(elem (i32.const 0x1b) $zeq)
(data (i32.const 0x033c)
"\30\03\00\00"
"\020=\00"
"\1b\00\00\00")
(elem (i32.const 0x1c) $zneq)
(data (i32.const 0x0348)
"\3c\03\00\00"
"\030<>"
"\1c\00\00\00")
(elem (i32.const 0x1d) $zlt)
(data (i32.const 0x0354)
"\48\03\00\00"
"\020<\00"
"\1d\00\00\00")
(elem (i32.const 0x1e) $zgt)
(data (i32.const 0x0360)
"\54\03\00\00"
"\020>\00"
"\1e\00\00\00")
(elem (i32.const 0x1f) $zlte)
(data (i32.const 0x036c)
"\60\03\00\00"
"\030<="
"\1f\00\00\00")
(elem (i32.const 0x20) $zgte)
(data (i32.const 0x0378)
"\6c\03\00\00"
"\030>="
"\20\00\00\00")
(elem (i32.const 0x21) $and)
(data (i32.const 0x0384)
"\78\03\00\00"
"\03AND"
"\21\00\00\00")
(elem (i32.const 0x22) $or)
(data (i32.const 0x0390)
"\84\03\00\00"
"\02OR\00"
"\22\00\00\00")
(elem (i32.const 0x23) $xor)
(data (i32.const 0x039c)
"\90\03\00\00"
"\03XOR"
"\23\00\00\00")
(elem (i32.const 0x24) $invert)
(data (i32.const 0x03a8)
"\90\03\00\00"
"\06INVERT\00"
"\24\00\00\00")
(elem (i32.const 0x25) $store)
(data (i32.const 0x03b8)
"\a8\03\00\00"
"\01!\00\00"
"\25\00\00\00")
(elem (i32.const 0x26) $fetch)
(data (i32.const 0x03c4)
"\b8\03\00\00"
"\01@\00\00"
"\26\00\00\00")
(elem (i32.const 0x27) $addstore)
(data (i32.const 0x03d0)
"\c4\03\00\00"
"\02+!\00"
"\27\00\00\00")
(elem (i32.const 0x28) $substore)
(data (i32.const 0x03dc)
"\d0\03\00\00"
"\02-!\00"
"\28\00\00\00")
(elem (i32.const 0x29) $storebyte)
(data (i32.const 0x03e8)
"\dc\03\00\00"
"\02C!\00"
"\29\00\00\00")
(elem (i32.const 0x2a) $fetchbyte)
(data (i32.const 0x03f4)
"\e8\03\00\00"
"\02C@\00"
"\2a\00\00\00")
(elem (i32.const 0x2b) $exit)
(data (i32.const 0x0400)
"\f4\03\00\00"
"\04EXIT\00\00\00"
"\2b\00\00\00")
(elem (i32.const 0x2c) $lit)
(data (i32.const 0x0410)
"\00\04\00\00"
"\03LIT"
"\2c\00\00\00")
(elem (i32.const 0x2d) $tor)
(data (i32.const 0x041c)
"\10\04\00\00"
"\02>R\00"
"\2d\00\00\00")
(elem (i32.const 0x2e) $fromr)
(data (i32.const 0x0428)
"\1c\04\00\00"
"\02R>\00"
"\2e\00\00\00")
(elem (i32.const 0x2f) $rspfetch)
(data (i32.const 0x434)
"\28\04\00\00"
"\04RSP@\00\00\00"
"\2f\00\00\00")
(elem (i32.const 0x30) $rspstore)
(data (i32.const 0x0444)
"\34\04\00\00"
"\04RSP!\00\00\00"
"\30\00\00\00")
(elem (i32.const 0x31) $rdrop)
(data (i32.const 0x0454)
"\44\04\00\00"
"\05RDROP\00\00"
"\31\00\00\00")
(elem (i32.const 0x32) $spfetch)
(data (i32.const 0x0464)
"\54\04\00\00"
"\03SP@"
"\32\00\00\00")
(elem (i32.const 0x33) $spstore)
(data (i32.const 0x0470)
"\64\04\00\00"
"\03SP!"
"\33\00\00\00")
(elem (i32.const 0x34) $key)
(data (i32.const 0x047c)
"\70\04\00\00"
"\03KEY"
"\34\00\00\00")
(elem (i32.const 0x35) $emit)
(data (i32.const 0x0488)
"\7c\04\00\00"
"\04EMIT\00\00\00"
"\35\00\00\00")
(elem (i32.const 0x36) $branch)
(data (i32.const 0x0498)
"\88\04\00\00"
"\06BRANCH\00"
"\36\00\00\00")
(elem (i32.const 0x37) $branch)
(data (i32.const 0x04a8)
"\98\04\00\00"
"\070BRANCH"
"\37\00\00\00")
;; Built-in constants and variables
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\05DOCOL\00\00"
;; "\01\00\00\00"
;; "\00\00\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\07DOCONST"
;; "\01\00\00\00"
;; "\01\00\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\05DOVAR\00\00"
;; "\01\00\00\00"
;; "\02\00\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\02R0\00"
;; "\01\00\00\00"
;; "\00\00\01\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\02S0\00"
;; "\01\00\00\00"
;; "\00\f0\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\05STATE\00\00"
;; "\02\00\00\00"
;; "\00\00\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\04BASE\00\00\00"
;; "\02\00\00\00"
;; "\0a\00\00\00")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\04HERE\00\00\00"
;; "\02\00\00\00"
;; "\??\??\??\??")
;; (data (i32.const 0x????)
;; "\??\??\??\??"
;; "\06LATEST\00"
;; "\02\00\00\00"
;; "\??\??\??\??")
;; Outer interpreter
;; The trampoline is the workaround for WebAssembly's lack of
;; indirect jumps, and lack of addresses for code. Instead of
;; jumping into the next codeword, NEXT sets the $fn global to the
;; function index of the next codeword and returns to the trampoline.
;;
;; This way, we can simulate jumping to the code within WebAssembly's
;; restrictions without the WebAssembly call stack growing unbounded
;; as would happen if we used call_indirect inside NEXT.
(func $trampoline
loop $loop
global.get $fn
call_indirect (type $codeword)
br $loop
end)
(func (export "reset")
i32.const 0xf000 global.set $sp ;; Set the stack pointer
;; i32.const 0x???? global.set $ip ;; Set the IP to point at QUIT
;; call $next
;; call $trampoline
))