uxnemu: fix console_vector handling

.gitignore

@@ -1,4 +1,5 @@
 *.rom
 *.rom.sym
+/_opam
 /_build
 /utils/uxnmin

README.md

@@ -1,5 +1,10 @@
-# Uxn\_of\_ocaml
+Yet another Uxn core, this time as an OCaml library.
 
-An Uxn emulator library for OCaml 5 (as it uses effect handlers)
+It has no dependencies, and depends on OCaml >=5.3 for its effect syntax.
 
+It was made for use in [Llop], a concatenative language targetting the Uxn
+virtual machine, but can be used for other purposes.  See `exe/uxnemu.ml` for
+a minimal Uxn/Varvara emulator that should be[1] able to run programs like
+Drifloon.
 
+[1]: Should be, because it's still a work in progress.

dune-project

@@ -16,4 +16,4 @@
  (name uxn)
  (synopsis "Uxn emulator library for OCaml")
  (description "Uxn emulator library for OCaml")
- (depends ocaml))
+ (depends (ocaml (>= 5.3))))

exe/uxnemu.ml

@@ -1,50 +1,39 @@
 open Uxn
 open Effect.Deep
 
-let print_stack ?(name = "wst") (Machine.Stack stack) =
-  if stack.sp != 0 then
-    let stack = Bytes.to_seq stack.data |> Seq.take stack.sp |> Bytes.of_seq in
-    Fmt.epr "@[%s: [@[%a@]]@]@." name (Fmt.on_bytes (Fmt.octets ())) stack
-
-let print_instruction i pc =
-  Fmt.epr "%6s (%02x) (PC = %04x)@." (Instr.to_string i) (Instr.to_int i) pc
-
 let debug = Option.is_some (Sys.getenv_opt "DBG")
-let console_vector = ref 0
 
-let dispatch =
+let rec run m pc =
-  if debug then
-    Machine.dispatch
-      ~dbg:
-        (Some
-           (fun m i pc ->
-             print_instruction i pc;
-             print_stack (Machine.wst m);
-             print_stack ~name:"rst" (Machine.rst m)))
-  else Machine.dispatch ~dbg:None
-
-let eval m pc =
   let dev = Machine.dev m in
-  let continue_with_console ch ty k =
+  let console_vector = ref 0 in
+  let console_input ch ty =
     Bytes.set_uint8 dev 0x12 ch;
     Bytes.set_uint8 dev 0x17 ty;
-    if !console_vector != 0 && Bytes.get_uint8 dev 0x0f = 0 then (
+    if Bytes.get_uint8 dev 0x0f = 0 then run m !console_vector
-      Fmt.epr "Continuing with console vector!\n";
-      continue k !console_vector)
   in
-  try dispatch m pc with
+  try Machine.dispatch ~trace:debug m pc with
-  | effect Machine.BRK, _ when Bytes.get_uint8 dev 0x0f != 0 -> ()
+  | effect Machine.Trace (pc, instr, args), k when debug ->
-  | effect Machine.BRK, k -> (
+      Fmt.epr "PC = %04x | %6s : %a\n" pc (Instr.to_string instr)
-      if !console_vector != 0 then
+        (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x"))
+        args;
+      Out_channel.flush stderr;
+      continue k ()
+  | effect Machine.Trace _, k -> continue k ()
+  | effect Machine.BRK, _ when !console_vector != 0 -> (
       try
         while Bytes.get_uint8 dev 0x0f = 0 do
-            match In_channel.input_char stdin with
+          match In_channel.input_byte stdin with
-            | None -> raise Exit
+          | None ->
-            | Some c -> continue_with_console (Char.code c) 1 k
+              if debug then Fmt.epr "EOF\n";
+              console_input 0 4;
+              raise Exit
+          | Some c -> console_input c 1
         done
-        with Exit -> continue_with_console 0 4 k)
+      with Exit -> ())
-  | effect Machine.DEI port, k -> continue k (Bytes.get_uint8 dev port)
+  | effect Machine.BRK, _ -> ()
-  | effect Machine.DEI2 port, k -> continue k (Util.get_uint16_wrap dev port)
+  | effect Machine.DEI (`Byte, port), k -> continue k (Bytes.get_uint8 dev port)
+  | effect Machine.DEI (`Short, port), k ->
+      continue k (Util.get_uint16_wrap dev port)
   | effect Machine.DEO (port, value), k ->
       (match port with
       | 0x10 -> console_vector := value
@@ -69,13 +58,7 @@ let main () =
   Out_channel.set_binary_mode stdout true;
 
   let mach = Machine.create code in
-  eval mach 0x100;
+  run mach 0x100;
-
+  exit (Bytes.get_uint8 (Machine.dev mach) 0x0f land 0x7f)
-  if debug then (
-    Fmt.epr "Execution ended:@.";
-    Machine.wst mach |> print_stack;
-    Machine.rst mach |> print_stack ~name:"rst");
-
-  Out_channel.flush_all ()
 
 let _ = main ()

lib/Machine.ml

@@ -72,9 +72,10 @@ type machine =
 
 type _ Effect.t +=
   | BRK : int Effect.t
-  | DEI : int -> int Effect.t
+  | DEI : ([ `Byte | `Short ] * int) -> int Effect.t
-  | DEI2 : int -> int Effect.t
   | DEO : (int * int) -> unit Effect.t
+  | Trace : (int * Instr.t * int list) -> unit Effect.t
+  | Breakpoint : int -> unit Effect.t
 
 type machine_state = Break | Next of int
 
@@ -94,17 +95,17 @@ let create code =
   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 dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) =
-  let cycles = ref cycles in
   let pc = ref pc in
-  while !cycles > 0 do
-    decr cycles;
 
+  while true do
     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 -> ());
+
+    let trace l = if trace then perform (Trace (!pc, instr, l)) in
+    if List.mem !pc breakpoints then perform (Breakpoint !pc);
 
     pc := (!pc + 1) land 0xffff;
 
@@ -113,25 +114,36 @@ let dispatch ?(dbg = None) ?(cycles = 65536) (Machine m) (pc : int) : unit =
     | 0x20 (* JCI *) ->
         let cond = pop1 m.stack in
         let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
+        trace [ Bytes.get_uint16_be m.data !pc; cond ];
         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
+        trace [ Bytes.get_uint16_be m.data !pc ];
         pc := !pc + addr + 2
     | 0x60 (* JSI *) ->
         let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
+        trace [ Bytes.get_uint16_be m.data !pc ];
         push2 m.callstack (!pc + 2);
         pc := !pc + addr + 2
     | 0x80 (* LIT *) ->
-        push1 m.stack (Bytes.get_uint8 m.data !pc);
+        let lit = Bytes.get_uint8 m.data !pc in
+        trace [ lit ];
+        push1 m.stack lit;
         pc := !pc + 1
     | 0xa0 (* LIT2 *) ->
-        push2 m.stack (Util.get_uint16_wrap ~wrap:0xffff m.data !pc);
+        let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
+        trace [ lit ];
+        push2 m.stack lit;
         pc := !pc + 2
     | 0xc0 (* LITr *) ->
-        push1 m.callstack (Bytes.get_uint8 m.data !pc);
+        let lit = Bytes.get_uint8 m.data !pc in
+        trace [ lit ];
+        push1 m.callstack lit;
         pc := !pc + 1
     | 0xe0 (* LIT2r *) ->
-        push2 m.callstack (Util.get_uint16_wrap ~wrap:0xffff m.data !pc);
+        let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
+        trace [ lit ];
+        push2 m.callstack lit;
         pc := !pc + 2
     | _ -> begin
         let (Instruction { short; keep; return; opcode }) = Instr.of_int op in
@@ -140,70 +152,80 @@ let dispatch ?(dbg = None) ?(cycles = 65536) (Machine m) (pc : int) : unit =
         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
+            trace [ r ];
             push mode stk (r + 1)
-        | 0x02 (* POP *) -> ignore (pop mode stk)
+        | 0x02 (* POP *) -> trace [ pop mode stk ]
         | 0x03 (* NIP *) ->
             let b = pop mode stk in
-            let _ = pop mode stk in
+            let a = pop mode stk in
+            trace [ a; b ];
             push mode stk b
         | 0x04 (* SWP *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             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
+            trace [ a; b; c ];
             push mode stk b;
             push mode stk c;
             push mode stk a
         | 0x06 (* DUP *) ->
             let a = peek mode stk in
+            trace [ a ];
             push mode stk a
         | 0x07 (* OVR *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             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
+            trace [ a; b ];
             pushbyte mode stk (if a = b then 1 else 0)
         | 0x09 (* NEQ *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             pushbyte mode stk (if a != b then 1 else 0)
         | 0x0a (* GTH *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             pushbyte mode stk (if a > b then 1 else 0)
         | 0x0b (* GTH *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             pushbyte mode stk (if a < b then 1 else 0)
         | 0x0c (* JMP *) ->
             let addr = pop mode stk in
+            trace [ addr ];
             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
+            trace [ cond; addr ];
             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
+            trace [ addr ];
             if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
         | 0x0f (* STH *) -> (
             let a = pop mode stk in
+            trace [ a ];
             match mode with
             | Mode mode ->
                 push
@@ -215,74 +237,91 @@ let dispatch ?(dbg = None) ?(cycles = 65536) (Machine m) (pc : int) : unit =
                   stk' a)
         | 0x10 (* LDZ *) ->
             let addr = popbyte mode stk in
+            trace [ addr ];
             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
+            trace [ v; addr ];
             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
+            trace [ addr ];
             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
+            trace [ v; addr ];
             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
+            trace [ addr ];
             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
+            trace [ v; addr ];
             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)
+            trace [ port ];
+            push mode stk
+              (perform (DEI ((if short then `Short else `Byte), port)))
         | 0x17 (* DEO *) ->
             let port = popbyte mode stk in
             let value = pop mode stk in
+            trace [ value; port ];
             if short then Util.set_uint16_wrap m.dev port value
             else Bytes.set_uint8 m.dev port value;
-            deo port value
+            perform (DEO (port, value))
         | 0x18 (* ADD *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             push mode stk (a + b)
         | 0x19 (* SUB *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             push mode stk (a - b)
         | 0x1a (* MUL *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             push mode stk (a * b)
         | 0x1b (* DIV *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             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
+            trace [ a; b ];
             push mode stk (a land b)
         | 0x1d (* ORA *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             push mode stk (a lor b)
         | 0x1e (* EOR *) ->
             let b = pop mode stk in
             let a = pop mode stk in
+            trace [ a; b ];
             push mode stk (a lxor b)
         | 0x1f (* SFT *) ->
             let sft = popbyte mode stk in
-            let a = pop mode stk in
+            let value = pop mode stk in
-            push mode stk ((a lsr (sft land 0xf)) lsl sft lsr 4)
+            trace [ value; sft ];
+            push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4)
       end
   done

lib/Machine.mli

@@ -21,16 +21,11 @@ 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 *)
+  | BRK : int Effect.t
-  | DEI : int -> int Effect.t
+  | DEI : ([ `Byte | `Short ] * int) -> int Effect.t
-  | DEI2 : int -> int Effect.t
   | DEO : (int * int) -> unit Effect.t
+  | Trace : (int * Instr.t * int list) -> unit Effect.t
+  | Breakpoint : int -> unit Effect.t
 
 val create : string -> machine
-
+val dispatch : ?trace:bool -> ?breakpoints:int list -> machine -> int -> 'a
-val dispatch :
-  ?dbg:(machine -> Instr.t -> int -> unit) option ->
-  ?cycles:int ->
-  machine ->
-  int ->
-  unit