diff --git a/.gitignore b/.gitignore index 9b3acb1..b1d2cf0 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.rom *.rom.sym +/_opam /_build /utils/uxnmin diff --git a/README.md b/README.md index dc59278..7412b30 100644 --- a/README.md +++ b/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. diff --git a/dune-project b/dune-project index b8c7172..3e8d74b 100644 --- a/dune-project +++ b/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)))) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 9b2bf5e..d57cffb 100644 --- a/exe/uxnemu.ml +++ b/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 = - 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 rec run 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 ( - Fmt.epr "Continuing with console vector!\n"; - continue k !console_vector) + if Bytes.get_uint8 dev 0x0f = 0 then run m !console_vector in - try dispatch m pc with - | effect Machine.BRK, _ when Bytes.get_uint8 dev 0x0f != 0 -> () - | effect Machine.BRK, k -> ( - if !console_vector != 0 then - try - while Bytes.get_uint8 dev 0x0f = 0 do - match In_channel.input_char stdin with - | None -> raise Exit - | Some c -> continue_with_console (Char.code c) 1 k - done - with Exit -> continue_with_console 0 4 k) - | effect Machine.DEI port, k -> continue k (Bytes.get_uint8 dev port) - | effect Machine.DEI2 port, k -> continue k (Util.get_uint16_wrap dev port) + try Machine.dispatch ~trace:debug m pc with + | effect Machine.Trace (pc, instr, args), k when debug -> + Fmt.epr "PC = %04x | %6s : %a\n" pc (Instr.to_string instr) + (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_byte stdin with + | None -> + if debug then Fmt.epr "EOF\n"; + console_input 0 4; + raise Exit + | Some c -> console_input c 1 + done + with Exit -> ()) + | effect Machine.BRK, _ -> () + | 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; - - if debug then ( - Fmt.epr "Execution ended:@."; - Machine.wst mach |> print_stack; - Machine.rst mach |> print_stack ~name:"rst"); - - Out_channel.flush_all () + run mach 0x100; + exit (Bytes.get_uint8 (Machine.dev mach) 0x0f land 0x7f) let _ = main () diff --git a/lib/Machine.ml b/lib/Machine.ml index e9b5bb3..8ceb7e2 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -72,9 +72,10 @@ type machine = type _ Effect.t += | BRK : int Effect.t - | DEI : int -> int Effect.t - | DEI2 : int -> 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 + | 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 cycles = ref cycles in +let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) = 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 - push mode stk ((a lsr (sft land 0xf)) lsl sft lsr 4) + let value = pop mode stk in + trace [ value; sft ]; + push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4) end done diff --git a/lib/Machine.mli b/lib/Machine.mli index 9837253..d71b339 100644 --- a/lib/Machine.mli +++ b/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 *) - | DEI : int -> int Effect.t - | DEI2 : int -> int 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 + | Breakpoint : int -> unit Effect.t val create : string -> machine - -val dispatch : - ?dbg:(machine -> Instr.t -> int -> unit) option -> - ?cycles:int -> - machine -> - int -> - unit +val dispatch : ?trace:bool -> ?breakpoints:int list -> machine -> int -> 'a