begin work on new device module system

exe/dune

@@ -1,4 +1,4 @@
 (executable
  (public_name uxnemu)
  (name uxnemu)
- (libraries uxn unix fmt))
+ (libraries uxn varvara unix fmt))

exe/uxnemu.ml

@@ -1,120 +1,41 @@
 open Uxn
 open Effect.Deep
 
-let debug = Option.is_some (Sys.getenv_opt "DBG")
+let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG")
-let banks = Array.init 15 (fun _ -> Bytes.create 65536)
 
-let get_bank_memory mach bank =
+module System = Varvara.System.Make ()
-  if bank = 0 then Machine.ram mach
+module Console = Varvara.Console.Make ()
-  else if bank > 0 && bank < 16 then banks.(bank - 1)
+module Devices = Uxn.Device.Compose (System) (Console)
-  else Bytes.create 0
-
-let system_expansion mach cmd_addr =
-  let ram = Machine.ram mach in
-  let cmd = Bytes.get_uint8 ram cmd_addr in
-  match cmd with
-  | 0x00 ->
-      let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
-      let bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
-      let addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
-      let value = Bytes.get_uint8 ram (cmd_addr + 7) in
-      if bank < 16 then begin
-        let mem = get_bank_memory mach bank in
-        for i = 0 to length - 1 do
-          let pos = (addr + i) land 0xffff in
-          Bytes.set_uint8 mem pos value
-        done
-      end
-  | 0x01 ->
-      let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
-      let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
-      let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
-      let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in
-      let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in
-      if src_bank < 16 && dst_bank < 16 then begin
-        let src_mem = get_bank_memory mach src_bank in
-        let dst_mem = get_bank_memory mach dst_bank in
-        for i = 0 to length - 1 do
-          let src_pos = (src_addr + i) land 0xffff in
-          let dst_pos = (dst_addr + i) land 0xffff in
-          let v = Bytes.get_uint8 src_mem src_pos in
-          Bytes.set_uint8 dst_mem dst_pos v
-        done
-      end
-  | 0x02 ->
-      let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
-      let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
-      let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
-      let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in
-      let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in
-      if src_bank < 16 && dst_bank < 16 then begin
-        let src_mem = get_bank_memory mach src_bank in
-        let dst_mem = get_bank_memory mach dst_bank in
-        for i = length - 1 downto 0 do
-          let src_pos = (src_addr + i) land 0xffff in
-          let dst_pos = (dst_addr + i) land 0xffff in
-          let v = Bytes.get_uint8 src_mem src_pos in
-          Bytes.set_uint8 dst_mem dst_pos v
-        done
-      end
-  | _ -> Fmt.epr "System/expansion: unknown command #%02x" cmd
 
 let print_stack ~name (Machine.Stack { data; sp }) =
   Fmt.epr "%s: @[%a@]@." name
     (Fmt.on_bytes (Fmt.octets ()))
     (Bytes.sub data 0 sp)
 
-let console_vector = ref 0
-
 let run m pc =
   let dev = Machine.dev m in
   let ram = Machine.ram m in
-  try Machine.dispatch ~trace:debug m pc with
+  try Machine.dispatch ~trace m pc with
-  | effect Machine.Trace (pc, instr, args), k when debug ->
+  | effect Machine.Trace (pc, instr, args), k ->
-      Fmt.epr "PC = %04x | %6s %a@." pc (Instr.to_string instr)
+      if trace then begin
-        (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x"))
+        Fmt.epr "PC = %04x | %6s %a@." pc (Instr.to_string instr)
-        args;
+          (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x"))
-      Out_channel.flush stderr;
+          args;
+        Out_channel.flush stderr
+      end;
       continue k ()
-  | effect Machine.Trace _, k -> continue k ()
   | effect Machine.BRK, _ -> ()
-  | effect Machine.DEI (`Byte, port), k ->
+  | effect Machine.DEI (`Byte, port), k -> (
-      let value =
+      match Devices.dei m port with
-        match port with
+      | Some v -> continue k v
-        | 0x04 ->
+      | None -> continue k (Bytes.get_uint8 dev port))
-            let (Machine.Stack { sp; _ }) = Machine.wst m in
+  | effect Machine.DEI (`Short, port), k -> (
-            sp
+      match Devices.dei2 m port with
-        | 0x05 ->
+      | Some v -> continue k v
-            let (Machine.Stack { sp; _ }) = Machine.rst m in
+      | None -> continue k (Util.get_uint16_wrap dev port))
-            sp
-        | _ -> Bytes.get_uint8 dev port
-      in
-      continue k value
-  | effect Machine.DEI (`Short, port), k ->
-      continue k (Util.get_uint16_wrap ~wrap:0xffff dev port)
   | effect Machine.DEO (port, value), k ->
       (match port with
-      | 0x02 -> system_expansion m value
+      | _ when Devices.can_handle port -> Devices.deo m port value
-      | 0x04 ->
-          let (Machine.Stack s) = Machine.wst m in
-          s.sp <- value land 0xff
-      | 0x05 ->
-          let (Machine.Stack s) = Machine.rst m in
-          s.sp <- value land 0xff
-      | 0x0e ->
-          if value <> 0 then begin
-            print_stack ~name:"WST" (Machine.wst m);
-            print_stack ~name:"RST" (Machine.rst m);
-            Out_channel.flush stderr
-          end
-      | 0x0f -> Bytes.set_uint8 dev 0x0f value
-      | 0x10 -> console_vector := Bytes.get_uint16_be dev 0x10
-      | 0x18 ->
-          print_char (Char.chr value);
-          Out_channel.flush stdout
-      | 0x19 ->
-          prerr_char (Char.chr value);
-          Out_channel.flush stderr
       | 0xaa -> Varvara.File.file_lengths.(0) <- Bytes.get_uint16_be dev 0xaa
       | 0xa4 ->
           let addr = Bytes.get_uint16_be dev 0xa4 in
@@ -186,11 +107,11 @@ let main () =
 
   run mach 0x100;
 
-  if !console_vector <> 0 then begin
+  if Console.state.console_vector <> 0 then begin
     let console_input ch ty =
       Bytes.set_uint8 dev 0x12 ch;
       Bytes.set_uint8 dev 0x17 ty;
-      if Bytes.get_uint8 dev 0x0f = 0 then run mach !console_vector
+      if Bytes.get_uint8 dev 0x0f = 0 then run mach Console.state.console_vector
     in
     if has_args then begin
       for i = 2 to Array.length Sys.argv - 1 do
@@ -211,7 +132,8 @@ let main () =
       done
     with Exit -> console_input 0 4
   end;
-  if debug then begin
+
+  if trace then begin
     print_stack ~name:"wst" (Machine.wst mach);
     print_stack ~name:"rst" (Machine.rst mach)
   end;

lib/Device.ml

@@ -0,0 +1,34 @@
+module type DEVICE = sig
+  type state
+
+  val state : state
+  val can_handle : int -> bool
+  val dei : Machine.machine -> int -> int option
+  val dei2 : Machine.machine -> int -> int option
+  val deo : Machine.machine -> int -> int -> unit
+end
+
+module Compose (D1 : DEVICE) (D2 : DEVICE) : DEVICE = struct
+  type state = D1.state * D2.state
+
+  let state = (D1.state, D2.state)
+  let can_handle port = D1.can_handle port || D2.can_handle port
+
+  let dei mach port =
+    match (D1.can_handle port, D2.can_handle port) with
+    | true, false -> D1.dei mach port
+    | false, true -> D2.dei mach port
+    | _ -> None
+
+  let dei2 mach port =
+    match (D1.can_handle port, D2.can_handle port) with
+    | true, false -> D1.dei2 mach port
+    | false, true -> D2.dei2 mach port
+    | _ -> None
+
+  let deo mach port value =
+    match (D1.can_handle port, D2.can_handle port) with
+    | true, false -> D1.deo mach port value
+    | false, true -> D2.deo mach port value
+    | _ -> ()
+end

lib/Machine.ml

@@ -92,7 +92,7 @@ let create code =
   Bytes.blit_string code 0 data 0x100 (String.length code);
   Machine { data; dev; stack = stack_create (); callstack = stack_create () }
 
-let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) =
+let dispatch ?(trace = false) (Machine m) (pc : int) =
   let pc = ref pc in
 
   while true do
@@ -100,9 +100,7 @@ let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) =
 
     let op = Bytes.get_uint8 m.data !pc in
     let instr = Instr.of_int op in
-
     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;
 

lib/Machine.mli

@@ -27,4 +27,4 @@ type _ Effect.t +=
   | Breakpoint : int -> unit Effect.t
 
 val create : string -> machine
-val dispatch : ?trace:bool -> ?breakpoints:int list -> machine -> int -> 'a
+val dispatch : ?trace:bool -> machine -> int -> 'a

lib/Varvara/Console.ml

@@ -0,0 +1,21 @@
+type state = { mutable console_vector : int }
+
+module Make () : Uxn.Device.DEVICE with type state = state = struct
+  type nonrec state = state
+
+  let state = { console_vector = 0 }
+  let can_handle port = port >= 0x10 && port <= 0x1f
+  let dei _ _ = None
+  let dei2 _ _ = None
+
+  let deo _ port value =
+    match port with
+    | 0x10 -> state.console_vector <- value
+    | 0x18 ->
+        print_char (Char.chr value);
+        Out_channel.flush stdout
+    | 0x19 ->
+        prerr_char (Char.chr value);
+        Out_channel.flush stderr
+    | _ -> ()
+end

lib/Varvara/File.ml

@@ -8,10 +8,11 @@ type file_state =
 type file_device = {
   mutable filepath : string option;
   mutable state : file_state;
+  mutable length : int;
 }
 
-let create_file_device () = { filepath = None; state = Idle }
+let make_file () = { filepath = None; state = Idle; length = 0 }
-let file_devices = [| create_file_device (); create_file_device () |]
+let file_devices = [| make_file (); make_file () |]
 let file_lengths = [| 0; 0 |]
 
 (* Read null-terminated string from RAM *)

lib/Varvara/System.ml

@@ -0,0 +1,100 @@
+open Uxn
+
+type state = { banks : bytes array }
+
+module Make () : Uxn.Device.DEVICE with type state = state = struct
+  type nonrec state = state
+
+  let state = { banks = Array.init 15 (fun _ -> Bytes.create 65536) }
+  let can_handle port = port >= 0x00 && port <= 0x0f
+
+  let print_stack ~name (Machine.Stack { data; sp }) =
+    Fmt.epr "%s: @[%a@]@." name
+      (Fmt.on_bytes (Fmt.octets ()))
+      (Bytes.sub data 0 sp)
+
+  let get_bank mach bank =
+    if bank = 0 then Machine.ram mach
+    else if bank > 0 && bank < 16 then state.banks.(bank - 1)
+    else Bytes.create 0
+
+  let expansion mach cmd_addr =
+    let ram = Machine.ram mach in
+    let cmd = Bytes.get_uint8 ram cmd_addr in
+    match cmd with
+    | 0x00 ->
+        let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
+        let bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
+        let addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
+        let value = Bytes.get_uint8 ram (cmd_addr + 7) in
+        if bank < 16 then begin
+          let mem = get_bank mach bank in
+          for i = 0 to length - 1 do
+            let pos = (addr + i) land 0xffff in
+            Bytes.set_uint8 mem pos value
+          done
+        end
+    | 0x01 ->
+        let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
+        let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
+        let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
+        let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in
+        let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in
+        if src_bank < 16 && dst_bank < 16 then begin
+          let src_mem = get_bank mach src_bank in
+          let dst_mem = get_bank mach dst_bank in
+          for i = 0 to length - 1 do
+            let src_pos = (src_addr + i) land 0xffff in
+            let dst_pos = (dst_addr + i) land 0xffff in
+            let v = Bytes.get_uint8 src_mem src_pos in
+            Bytes.set_uint8 dst_mem dst_pos v
+          done
+        end
+    | 0x02 ->
+        let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in
+        let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in
+        let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in
+        let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in
+        let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in
+        if src_bank < 16 && dst_bank < 16 then begin
+          let src_mem = get_bank mach src_bank in
+          let dst_mem = get_bank mach dst_bank in
+          for i = length - 1 downto 0 do
+            let src_pos = (src_addr + i) land 0xffff in
+            let dst_pos = (dst_addr + i) land 0xffff in
+            let v = Bytes.get_uint8 src_mem src_pos in
+            Bytes.set_uint8 dst_mem dst_pos v
+          done
+        end
+    | _ -> Format.eprintf "System/expansion: unknown command #%02x" cmd
+
+  let dei m port =
+    match port with
+    | 0x04 ->
+        let (Machine.Stack { sp; _ }) = Machine.wst m in
+        Some sp
+    | 0x05 ->
+        let (Machine.Stack { sp; _ }) = Machine.rst m in
+        Some sp
+    | _ -> None
+
+  let dei2 _ _ = None
+
+  let deo mach port value =
+    match port with
+    | 0x02 -> expansion mach value
+    | 0x04 ->
+        let (Machine.Stack s) = Machine.wst mach in
+        s.sp <- value land 0xff
+    | 0x05 ->
+        let (Machine.Stack s) = Machine.rst mach in
+        s.sp <- value land 0xff
+    | 0x0e ->
+        if value <> 0 then begin
+          print_stack ~name:"wst" (Machine.wst mach);
+          print_stack ~name:"rst" (Machine.rst mach);
+          Out_channel.flush stderr
+        end
+    | 0x0f -> Bytes.set_uint8 (Machine.dev mach) 0x0f value
+    | _ -> ()
+end

lib/Varvara/dune

@@ -0,0 +1,3 @@
+(library
+  (name varvara)
+  (libraries uxn fmt unix))

lib/dune

@@ -1,5 +1,3 @@
-(include_subdirs qualified)
-
 (library
  (name uxn)
  (libraries unix))

shell.nix

@@ -5,6 +5,7 @@
 pkgs.mkShell {
   buildInputs = with pkgs; [
     xxd
+    uxn
     ocamlPackages.ocaml
     ocamlPackages.dune_3
     ocamlPackages.findlib