initial import

lib/Instr.ml

@@ -0,0 +1,73 @@
+let short_mask = 0x20
+let return_mask = 0x40
+let keep_mask = 0x80
+let opcode_mask = 0x1f
+
+let opcode_names =
+  [|
+    "BRK";
+    "INC";
+    "POP";
+    "NIP";
+    "SWP";
+    "ROT";
+    "DUP";
+    "OVR";
+    "EQU";
+    "NEQ";
+    "GTH";
+    "LTH";
+    "JMP";
+    "JCN";
+    "JSR";
+    "STH";
+    "LDZ";
+    "STZ";
+    "LDR";
+    "STR";
+    "LDA";
+    "STA";
+    "DEI";
+    "DEO";
+    "ADD";
+    "SUB";
+    "MUL";
+    "DIV";
+    "AND";
+    "ORA";
+    "EOR";
+    "SFT";
+  |]
+
+type t =
+  | Instruction of { short : bool; return : bool; keep : bool; opcode : int }
+
+let of_int (op : int) : t =
+  let has_mask mask = op land mask = mask in
+  let short = has_mask short_mask in
+  let return = has_mask return_mask in
+  let keep = has_mask keep_mask in
+  match op with
+  | 0x20 | 0x40 | 0x60 ->
+      Instruction { short = false; return = false; keep = false; opcode = op }
+  | 0x80 | 0xa0 | 0xc0 | 0xe0 ->
+      Instruction { short; return; keep = false; opcode = 0x80 }
+  | _ -> Instruction { short; return; keep; opcode = Int.logand op opcode_mask }
+
+let to_int (Instruction { opcode; short; keep; return } : t) : int =
+  let flags = if short then short_mask else 0 in
+  let flags = if return then Int.logor flags return_mask else flags in
+  let flags = if keep then Int.logor flags keep_mask else flags in
+  opcode lor flags
+
+let to_string (Instruction { opcode; short; keep; return } : t) : string =
+  Format.sprintf "%s%s%s%s"
+    (match opcode with
+    | 0x20 -> "JCI"
+    | 0x40 -> "JMI"
+    | 0x60 -> "JSI"
+    | 0x80 -> "LIT"
+    | _ -> opcode_names.(opcode))
+    (if short then "2" else "")
+    (if keep then "k" else "")
+    (if return then "r" else "")

lib/Instr.mli

@@ -0,0 +1,6 @@
+type t =
+  | Instruction of { short : bool; return : bool; keep : bool; opcode : int }
+
+val of_int : int -> t
+val to_int : t -> int
+val to_string : t -> string

lib/Machine.ml

@@ -0,0 +1,288 @@
+(* Unoptimized Uxn virtual machine. *)
+
+open Effect
+
+type stack = Stack of { data : bytes; mutable sp : int }
+type mode = Mode of { short : bool; keep : bool; mutable temp : int }
+
+let stack_create () = Stack { data = Bytes.create 256; sp = 0 }
+
+let peek (Mode { short; keep; temp }) (Stack { data; sp }) : int =
+  let amt = if short then 2 else 1 in
+  let sp = if keep then (temp - amt) land 0xff else (sp - amt) land 0xff in
+  if short then Util.get_uint16_wrap data sp else Bytes.get_uint8 data sp
+[@@inline]
+
+let pop (Mode m as m' : mode) (Stack s' as s : stack) =
+  let res = peek m' s in
+  let amt = if m.short then 2 else 1 in
+  if m.keep then m.temp <- (m.temp - amt) land 0xff
+  else s'.sp <- (s'.sp - amt) land 0xff;
+  res
+[@@inline]
+
+let push (Mode ({ short; keep; _ } as m) : mode) (Stack s : stack) (v : int) =
+  if short then Util.set_uint16_wrap s.data s.sp (v land 0xffff)
+  else Bytes.set_uint8 s.data s.sp (v land 0xff);
+  let amt = if m.short then 2 else 1 in
+  if keep then m.temp <- (m.temp + amt) land 0xff;
+  s.sp <- (s.sp + amt) land 0xff
+[@@inline]
+
+let pushbyte (Mode m) s v =
+  let m' = Mode { m with short = false } in
+  push m' s v;
+  let (Mode { temp; _ }) = m' in
+  m.temp <- temp
+[@@inline]
+
+let pushshort (Mode m) s v =
+  let m' = Mode { m with short = true } in
+  push m' s v;
+  let (Mode { temp; _ }) = m' in
+  m.temp <- temp
+[@@inline]
+
+let popbyte (Mode m) s =
+  let m' = Mode { m with short = false } in
+  let r = pop m' s in
+  let (Mode { temp; _ }) = m' in
+  m.temp <- temp;
+  r
+[@@inline]
+
+let popshort (Mode m) s =
+  let m' = Mode { m with short = true } in
+  let r = pop m' s in
+  let (Mode { temp; _ }) = m' in
+  m.temp <- temp;
+  r
+[@@inline]
+
+let pop1 s = pop (Mode { short = false; keep = false; temp = 0 }) s [@@inline]
+
+let push1 s v = push (Mode { short = false; keep = false; temp = 0 }) s v
+[@@inline]
+
+let push2 s v = push (Mode { short = true; keep = false; temp = 0 }) s v
+[@@inline]
+
+type machine =
+  | Machine of { data : bytes; dev : bytes; stack : stack; callstack : stack }
+
+type _ Effect.t +=
+  | BRK : int Effect.t
+  | DEI : int -> int Effect.t
+  | DEI2 : int -> int Effect.t
+  | DEO : (int * int) -> unit Effect.t
+
+type machine_state = Break | Next of int
+
+let ram (Machine { data; _ }) = data
+let dev (Machine { dev; _ }) = dev
+let wst (Machine { stack; _ }) = stack
+let rst (Machine { callstack; _ }) = callstack
+
+let stack (Machine { stack; callstack; _ }) mode =
+  if mode then callstack else stack
+
+let create code =
+  let data = Bytes.create 65536 in
+  let dev = Bytes.create 256 in
+  Bytes.unsafe_fill data 0 65536 '\x00';
+  Bytes.unsafe_fill dev 0 256 '\x00';
+  Bytes.blit_string code 0 data 0x100 (String.length code);
+  Machine { data; dev; stack = stack_create (); callstack = stack_create () }
+
+let dispatch ?(dbg = None) ?(cycles = 65536) (Machine m) (pc : int) : unit =
+  let cycles = ref cycles in
+  let pc = ref pc in
+  while !cycles > 0 do
+    decr cycles;
+
+    pc := !pc land 0xffff;
+
+    let op = Bytes.get_uint8 m.data !pc in
+    let instr = Instr.of_int op in
+    (match dbg with Some dbg -> dbg (Machine m) instr !pc | None -> ());
+
+    pc := (!pc + 1) land 0xffff;
+
+    match op with
+    | 0x00 -> pc := perform BRK
+    | 0x20 (* JCI *) ->
+        let cond = pop1 m.stack in
+        let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
+        if cond != 0 then pc := !pc + addr + 2 else pc := !pc + 2
+    | 0x40 (* JMI *) ->
+        let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
+        pc := !pc + addr + 2
+    | 0x60 (* JSI *) ->
+        let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
+        push2 m.callstack (!pc + 2);
+        pc := !pc + addr + 2
+    | 0x80 (* LIT *) ->
+        push1 m.stack (Bytes.get_uint8 m.data !pc);
+        pc := !pc + 1
+    | 0xa0 (* LIT2 *) ->
+        push2 m.stack (Util.get_uint16_wrap ~wrap:0xffff m.data !pc);
+        pc := !pc + 2
+    | 0xc0 (* LITr *) ->
+        push1 m.callstack (Bytes.get_uint8 m.data !pc);
+        pc := !pc + 1
+    | 0xe0 (* LIT2r *) ->
+        push2 m.callstack (Util.get_uint16_wrap ~wrap:0xffff m.data !pc);
+        pc := !pc + 2
+    | _ -> begin
+        let (Instruction { short; keep; return; opcode }) = Instr.of_int op in
+        let stk = if return then m.callstack else m.stack in
+        let stk' = if return then m.stack else m.callstack in
+        let mode =
+          Mode { short; keep; temp = (match stk with Stack { sp; _ } -> sp) }
+        in
+        let deo port value = perform (DEO (port, value)) in
+        let dei port =
+          if short then perform (DEI2 port) else perform (DEI port)
+        in
+        match[@warning "-8"] opcode with
+        | 0x01 (* INC *) ->
+            let r = pop mode stk in
+            push mode stk (r + 1)
+        | 0x02 (* POP *) -> ignore (pop mode stk)
+        | 0x03 (* NIP *) ->
+            let b = pop mode stk in
+            let _ = pop mode stk in
+            push mode stk b
+        | 0x04 (* SWP *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk b;
+            push mode stk a
+        | 0x05 (* ROT *) ->
+            let c = pop mode stk in
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk b;
+            push mode stk c;
+            push mode stk a
+        | 0x06 (* DUP *) ->
+            let a = peek mode stk in
+            push mode stk a
+        | 0x07 (* OVR *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk a;
+            push mode stk b;
+            push mode stk a
+        | 0x08 (* EQU *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            pushbyte mode stk (if a = b then 1 else 0)
+        | 0x09 (* NEQ *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            pushbyte mode stk (if a != b then 1 else 0)
+        | 0x0a (* GTH *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            pushbyte mode stk (if a > b then 1 else 0)
+        | 0x0b (* GTH *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            pushbyte mode stk (if a < b then 1 else 0)
+        | 0x0c (* JMP *) ->
+            let addr = pop mode stk in
+            if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
+        | 0x0d (* JCN *) ->
+            let addr = pop mode stk in
+            let cond = popbyte mode stk in
+            if cond != 0 then
+              if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
+        | 0x0e (* JSR *) ->
+            push2 m.callstack !pc;
+            let addr = pop mode stk in
+            if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
+        | 0x0f (* STH *) -> (
+            let a = pop mode stk in
+            match mode with
+            | Mode mode ->
+                push
+                  (Mode
+                     {
+                       mode with
+                       temp = (match stk' with Stack { sp; _ } -> sp);
+                     })
+                  stk' a)
+        | 0x10 (* LDZ *) ->
+            let addr = popbyte mode stk in
+            push mode stk
+              (if short then Util.get_uint16_wrap m.data addr
+               else Bytes.get_uint8 m.data addr)
+        | 0x11 (* STZ *) ->
+            let addr = popbyte mode stk in
+            let v = pop mode stk in
+            if short then Util.set_uint16_wrap m.data addr v
+            else Bytes.set_uint8 m.data addr v
+        | 0x12 (* LDR *) ->
+            let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in
+            push mode stk
+              (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr
+               else Bytes.get_uint8 m.data addr)
+        | 0x13 (* STR *) ->
+            let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in
+            let v = pop mode stk in
+            if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v
+            else Bytes.set_uint8 m.data addr v
+        | 0x14 (* LDA *) ->
+            let addr = popshort mode stk in
+            push mode stk
+              (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr
+               else Bytes.get_uint8 m.data addr)
+        | 0x15 (* STA *) ->
+            let addr = popshort mode stk in
+            let v = pop mode stk in
+            if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v
+            else Bytes.set_uint8 m.data addr v
+        | 0x16 (* DEI *) ->
+            let port = popbyte mode stk in
+            push mode stk (dei port)
+        | 0x17 (* DEO *) ->
+            let port = popbyte mode stk in
+            let value = pop mode stk in
+            if short then Util.set_uint16_wrap m.dev port value
+            else Bytes.set_uint8 m.dev port value;
+            deo port value
+        | 0x18 (* ADD *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a + b)
+        | 0x19 (* SUB *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a - b)
+        | 0x1a (* MUL *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a * b)
+        | 0x1b (* DIV *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (if b = 0 then 0 else a / b)
+        | 0x1c (* AND *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a land b)
+        | 0x1d (* ORA *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a lor b)
+        | 0x1e (* EOR *) ->
+            let b = pop mode stk in
+            let a = pop mode stk in
+            push mode stk (a lxor b)
+        | 0x1f (* SFT *) ->
+            let sft = popbyte mode stk in
+            let a = pop mode stk in
+            push mode stk ((a lsr (sft land 0xf)) lsl sft lsr 4)
+      end
+  done

lib/Machine.mli

@@ -0,0 +1,36 @@
+type stack = Stack of { data : bytes; mutable sp : int }
+type mode = Mode of { short : bool; keep : bool; mutable temp : int }
+
+val stack_create : unit -> stack
+val peek : mode -> stack -> int
+val pop : mode -> stack -> int
+val push : mode -> stack -> int -> unit
+val pushbyte : mode -> stack -> int -> unit
+val pushshort : mode -> stack -> int -> unit
+val popbyte : mode -> stack -> int
+val popshort : mode -> stack -> int
+
+type machine
+
+val ram : machine -> bytes
+val dev : machine -> bytes
+val wst : machine -> stack
+val rst : machine -> stack
+val stack : machine -> bool -> stack
+
+type machine_state = Break | Next of int
+
+type _ Effect.t +=
+  | BRK : int Effect.t (* Returns a new PC if handled *)
+  | DEI : int -> int Effect.t
+  | DEI2 : int -> int Effect.t
+  | DEO : (int * int) -> unit Effect.t
+
+val create : string -> machine
+
+val dispatch :
+  ?dbg:(machine -> Instr.t -> int -> unit) option ->
+  ?cycles:int ->
+  machine ->
+  int ->
+  unit

lib/Util.ml

@@ -0,0 +1,17 @@
+let uint8_to_int8 i = (i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
+let uint16_to_int16 i = (i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_uint16_wrap ?(wrap = 0xff) (bytes : bytes) (position : int) : int =
+  let i0 = position land wrap in
+  let hi = Bytes.get_uint8 bytes i0 in
+  let lo = Bytes.get_uint8 bytes ((i0 + 1) land wrap) in
+  (hi lsl 8) lor lo
+
+let get_int16_wrap ?(wrap = 0xff) (bytes : bytes) (position : int) : int =
+  get_uint16_wrap ~wrap bytes position |> uint16_to_int16
+
+let set_uint16_wrap ?(wrap = 0xff) (bytes : bytes) (position : int)
+    (value : int) : unit =
+  let i0 = position land wrap in
+  Bytes.set_uint8 bytes i0 ((value lsr 8) land 0xff);
+  Bytes.set_uint8 bytes ((i0 + 1) land wrap) (value land 0xff)

lib/Util.mli

@@ -0,0 +1,5 @@
+val uint8_to_int8 : int -> int
+val uint16_to_int16 : int -> int
+val get_uint16_wrap : ?wrap:int -> bytes -> int -> int
+val get_int16_wrap : ?wrap:int -> bytes -> int -> int
+val set_uint16_wrap : ?wrap:int -> bytes -> int -> int -> unit

lib/dune

@@ -0,0 +1,2 @@
+(library
+ (name uxn))