add datetime device, revise device handling, remove tracing code

exe/uxnemu.ml

@@ -1,44 +1,54 @@
 open Uxn
 open Effect.Deep
 
-let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG")
+let devices_deo = Hashtbl.create 256
+let devices_dei = Hashtbl.create 256
+
+let register_device (module D : Device.DEVICE) =
+  Device.Int_set.iter
+    (fun port -> Hashtbl.add devices_dei port (module D : Device.DEVICE))
+    D.dei_ports;
+  Device.Int_set.iter
+    (fun port -> Hashtbl.add devices_deo port (module D : Device.DEVICE))
+    D.deo_ports
 
 module System = Varvara.System.Make ()
 module Console = Varvara.Console.Make ()
+module Datetime = Varvara.Datetime.Make ()
 
-module File =
+module File_a = Varvara.File.Make (struct
-  Uxn.Device.Compose
-    (Varvara.File.Make (struct
   let start = 0xa0
-    end))
+end)
-    (Varvara.File.Make (struct
-      let start = 0xb0
-    end))
 
-module Devices =
+module File_b = Varvara.File.Make (struct
-  Uxn.Device.Compose (Uxn.Device.Compose (System) (Console)) (File)
+  let start = 0xb0
+end)
 
 let run m pc =
   let dev = Machine.dev m in
-  try Machine.dispatch ~trace m pc with
+  try Machine.dispatch m pc with
-  | effect Machine.Trace (pc, instr, args), k ->
-      if trace then begin
-        Printf.eprintf "PC = %04x %6s %s\n" pc (Instr.to_string instr)
-          (List.map (Format.sprintf "%02x") args |> String.concat " ");
-        Out_channel.flush stderr
-      end;
-      continue k ()
   | effect Machine.BRK, _ -> ()
-  | effect Machine.DEI (`Byte, port), k -> (
+  | effect Machine.DEI (`Byte, port), k -> begin
-      match Devices.dei m port with
+      try
-      | Some v -> continue k v
+        let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE)
-      | None -> continue k (Bytes.get_uint8 dev port))
+        in
-  | effect Machine.DEI (`Short, port), k -> (
+        continue k (Device.dei m port)
-      match Devices.dei2 m port with
+      with Not_found -> continue k (Bytes.get_uint8 dev port)
-      | Some v -> continue k v
+    end
-      | None -> continue k (Util.get_uint16_wrap dev port))
+  | effect Machine.DEI (`Short, port), k -> begin
+      try
+        let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE)
+        in
+        continue k (Device.dei2 m port)
+      with Not_found -> continue k (Util.get_uint16_wrap dev port)
+    end
   | effect Machine.DEO (port, value), k ->
-      if Devices.can_handle port then Devices.deo m port value;
+      begin try
+        let module Device = (val Hashtbl.find devices_deo port : Device.DEVICE)
+        in
+        Device.deo m port value
+      with Not_found -> ()
+      end;
       continue k ()
 
 let main () =
@@ -46,6 +56,12 @@ let main () =
     Printf.eprintf "usage: uxnemu file.rom ...\n";
     exit 1);
 
+  register_device (module System : Device.DEVICE);
+  register_device (module Console : Device.DEVICE);
+  register_device (module File_a : Device.DEVICE);
+  register_device (module File_b : Device.DEVICE);
+  register_device (module Datetime : Device.DEVICE);
+
   let code =
     In_channel.with_open_bin Sys.argv.(1) (fun i -> In_channel.input_all i)
   in

lib/Device.ml

@@ -1,35 +1,12 @@
+module Int_set = Set.Make (Int)
+
 module type DEVICE = sig
   type state
 
   val state : state
-  val can_handle : int -> bool
+  val dei_ports : Int_set.t
-  val dei : Machine.machine -> int -> int option
+  val deo_ports : Int_set.t
-  val dei2 : Machine.machine -> int -> int option
+  val dei : Machine.machine -> int -> int
+  val dei2 : Machine.machine -> int -> int
   val deo : Machine.machine -> int -> int -> unit
 end
-
-module Compose (D1 : DEVICE) (D2 : DEVICE) :
-  DEVICE with type state = D1.state * D2.state = 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

@@ -70,7 +70,6 @@ type _ Effect.t +=
   | BRK : int Effect.t
   | DEI : ([ `Byte | `Short ] * int) -> int Effect.t
   | DEO : (int * int) -> unit Effect.t
-  | Trace : (int * Instr.t * int list) -> unit Effect.t
 
 let ram (Machine { data; _ }) = data
 let dev (Machine { dev; _ }) = dev
@@ -85,13 +84,8 @@ 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) (Machine m) (pc : int) =
+let dispatch (Machine m) (pc : int) =
   let pc = ref pc in
-  let trace op l =
-    if trace then
-      let instr = Instr.of_int op in
-      perform (Trace (!pc, instr, l))
-  in
 
   while true do
     let op = Bytes.get_uint8 m.data (!pc land 0xffff) in
@@ -107,35 +101,28 @@ let dispatch ?(trace = false) (Machine m) (pc : int) =
     | 0x20 (* JCI *) ->
         let cond = pop1 m.stack in
         let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
-        trace op [ 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 op [ 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 op [ Bytes.get_uint16_be m.data !pc ];
         push2 m.callstack (!pc + 2);
         pc := !pc + addr + 2
     | 0x80 (* LIT *) ->
         let lit = Bytes.get_uint8 m.data !pc in
-        trace op [ lit ];
         push1 m.stack lit;
         pc := !pc + 1
     | 0xa0 (* LIT2 *) ->
         let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
-        trace op [ lit ];
         push2 m.stack lit;
         pc := !pc + 2
     | 0xc0 (* LITr *) ->
         let lit = Bytes.get_uint8 m.data !pc in
-        trace op [ lit ];
         push1 m.callstack lit;
         pc := !pc + 1
     | 0xe0 (* LIT2r *) ->
         let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
-        trace op [ lit ];
         push2 m.callstack lit;
         pc := !pc + 2
     | _ -> begin
@@ -147,166 +134,136 @@ let dispatch ?(trace = false) (Machine m) (pc : int) =
         match[@warning "-8"] opcode with
         | 0x01 (* INC *) ->
             let r = pop mode stk in
-            trace op [ r ];
             push mode stk (r + 1)
-        | 0x02 (* POP *) -> trace op [ pop mode stk ]
+        | 0x02 (* POP *) -> ignore (pop mode stk)
         | 0x03 (* NIP *) ->
             let b = pop mode stk in
-            let a = pop mode stk in
+            ignore (pop mode stk);
-            trace op [ a; b ];
             push mode stk b
         | 0x04 (* SWP *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ 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 op [ a; b; c ];
             push mode stk b;
             push mode stk c;
             push mode stk a
         | 0x06 (* DUP *) ->
             let a = pop mode stk in
-            trace op [ a ];
             push mode stk a;
             push mode stk a
         | 0x07 (* OVR *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ 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 op [ 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 op [ 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 op [ a; b ];
             pushbyte mode stk (if a > b then 1 else 0)
         | 0x0b (* LTH *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             pushbyte mode stk (if a < b then 1 else 0)
         | 0x0c (* JMP *) ->
             let addr = pop mode stk in
-            trace op [ 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 op [ 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 op [ addr ];
             if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
         | 0x0f (* STH *) ->
             let a = pop mode stk in
-            trace op [ a ];
             push mode stk' a
         | 0x10 (* LDZ *) ->
             let addr = popbyte mode stk in
-            trace op [ 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 op [ 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 op [ 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 op [ 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 op [ 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 op [ 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
-            trace op [ 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 op [ value; port ];
             if short then Util.set_uint16_wrap m.dev port value
             else Bytes.set_uint8 m.dev port value;
             perform (DEO (port, value))
         | 0x18 (* ADD *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             push mode stk (a + b)
         | 0x19 (* SUB *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             push mode stk (a - b)
         | 0x1a (* MUL *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             push mode stk (a * b)
         | 0x1b (* DIV *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ 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 op [ a; b ];
             push mode stk (a land b)
         | 0x1d (* ORA *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             push mode stk (a lor b)
         | 0x1e (* EOR *) ->
             let b = pop mode stk in
             let a = pop mode stk in
-            trace op [ a; b ];
             push mode stk (a lxor b)
         | 0x1f (* SFT *) ->
             let sft = popbyte mode stk in
             let value = pop mode stk in
-            trace op [ value; sft ];
             push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4)
       end
   done

lib/Machine.mli

@@ -17,7 +17,6 @@ type _ Effect.t +=
   | BRK : int Effect.t
   | DEI : ([ `Byte | `Short ] * int) -> int Effect.t
   | DEO : (int * int) -> unit Effect.t
-  | Trace : (int * Instr.t * int list) -> unit Effect.t
 
 val create : string -> machine
-val dispatch : ?trace:bool -> machine -> int -> 'a
+val dispatch : machine -> int -> 'a

lib/Varvara/Console.ml

@@ -4,9 +4,10 @@ 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_ports = Uxn.Device.Int_set.empty
-  let dei _ _ = None
+  let deo_ports = Uxn.Device.Int_set.of_list [ 0x10; 0x18; 0x19 ]
-  let dei2 _ _ = None
+  let dei _ _ = assert false
+  let dei2 _ _ = assert false
 
   let deo _ port value =
     match port with
@@ -17,5 +18,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
     | 0x19 ->
         prerr_char (Char.chr value);
         Out_channel.flush stderr
-    | _ -> ()
+    | _ -> assert false
 end

lib/Varvara/Datetime.ml

@@ -0,0 +1,34 @@
+module Make () : Uxn.Device.DEVICE with type state = unit = struct
+  type state = unit
+
+  let state = ()
+
+  let dei_ports =
+    Uxn.Device.Int_set.of_list
+      [ 0xc0; 0xc2; 0xc3; 0xc4; 0xc5; 0xc6; 0xc7; 0xc8; 0xca ]
+
+  let deo_ports = Uxn.Device.Int_set.empty
+
+  let dei _ port =
+    let now = Unix.time () in
+    let tm = Unix.localtime now in
+    match port with
+    | 0xc2 -> tm.Unix.tm_mon
+    | 0xc3 -> tm.Unix.tm_mday
+    | 0xc4 -> tm.Unix.tm_hour
+    | 0xc5 -> tm.Unix.tm_min
+    | 0xc6 -> tm.Unix.tm_sec
+    | 0xc7 -> tm.Unix.tm_wday
+    | 0xca -> Bool.to_int tm.Unix.tm_isdst
+    | _ -> assert false
+
+  let dei2 _ port =
+    let now = Unix.time () in
+    let tm = Unix.localtime now in
+    match port with
+    | 0xc0 -> tm.Unix.tm_year + 1900
+    | 0xc8 -> tm.Unix.tm_yday
+    | _ -> assert false
+
+  let deo _ _ _ = assert false
+end

lib/Varvara/File.ml

@@ -19,7 +19,18 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
   type nonrec state = state
 
   let state = { filepath = None; state = Idle; length = 0 }
-  let can_handle port = port >= Addr.start && port <= Addr.start + 0x0f
+  let dei_ports = Uxn.Device.Int_set.empty
+
+  let deo_ports =
+    Uxn.Device.Int_set.of_list
+      [
+        Addr.start + 0x0a;
+        Addr.start + 0x04;
+        Addr.start + 0x06;
+        Addr.start + 0x08;
+        Addr.start + 0x0c;
+        Addr.start + 0x0e;
+      ]
 
   let read_cstring ram addr =
     let buf = Buffer.create 256 in
@@ -194,8 +205,8 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
           with Unix.Unix_error _ -> -1)
 
   let file_success dev port value = Bytes.set_uint16_be dev port value
-  let dei _ _ = None
+  let dei _ _ = assert false
-  let dei2 _ _ = None
+  let dei2 _ _ = assert false
 
   let deo mach port value =
     let open Uxn in
@@ -211,5 +222,5 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
     | 0x0e ->
         let append = Bytes.get_uint8 dev (Addr.start + 0x07) in
         file_write ram value state.length append |> with_success
-    | _ -> ()
+    | _ -> failwith (Printf.sprintf "%02x" port)
 end

lib/Varvara/System.ml

@@ -6,7 +6,8 @@ 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 dei_ports = Uxn.Device.Int_set.of_list [ 0x04; 0x05 ]
+  let deo_ports = Uxn.Device.Int_set.of_list [ 0x02; 0x04; 0x05; 0x0e; 0x0f ]
 
   let print_stack ~name (Machine.Stack { data; sp }) =
     Printf.eprintf "%s " name;
@@ -76,13 +77,13 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
     match port with
     | 0x04 ->
         let (Machine.Stack { sp; _ }) = Machine.wst m in
-        Some sp
+        sp
     | 0x05 ->
         let (Machine.Stack { sp; _ }) = Machine.rst m in
-        Some sp
+        sp
-    | _ -> None
+    | _ -> assert false
 
-  let dei2 _ _ = None
+  let dei2 _ _ = assert false
 
   let deo mach port value =
     match port with
@@ -100,5 +101,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
           Out_channel.flush stderr
         end
     | 0x0f -> Bytes.set_uint8 (Machine.dev mach) 0x0f value
-    | _ -> ()
+    | _ -> assert false
 end