├── .gitignore ├── README.md ├── archived ├── arbiter.ml ├── arbiter.mli ├── codes.ml ├── hardcamlrun.ml ├── simple.ml ├── zinc.ml ├── zinc.mli └── zinc_tb.ml ├── bin ├── dune └── monadinterp.ml ├── dune-project ├── hardcaml_zinc.opam ├── src ├── c_runtime.ml ├── c_runtime.mli ├── compile_hardware.ml ├── compile_hardware.mli ├── dune ├── framework.ml ├── framework.mli ├── instruction.ml ├── instruction.mli ├── interp.ml ├── interp.mli ├── load.ml ├── load.mli ├── machine.ml ├── machine.mli ├── memory.ml ├── memory.mli ├── mlvalues.ml ├── mlvalues.mli ├── opcode.ml ├── opcode.mli ├── ops.ml ├── ops.mli ├── repr.ml ├── repr.mli ├── trace.ml └── trace.mli ├── test ├── examples │ ├── dune │ └── helloworld.ml └── lib │ ├── dune │ ├── instruction_display_rules.ml │ ├── instruction_display_rules.mli │ ├── test_compile.ml │ ├── test_compile.mli │ ├── test_loader.ml │ ├── test_loader.mli │ ├── test_repr.ml │ ├── test_repr.mli │ ├── test_show_instructions.ml │ └── test_show_instructions.mli └── zinc.md /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .*.swp 3 | _build/ 4 | .merlin 5 | .ocamlformat 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # General 2 | 3 | An implementation of the ZINC Abstract Machine (ZAM) in HardCaml 4 | for running OCaml bytecode programs in hardware. 5 | 6 | **Status** Transitioning to a new way of implementating the hardware 7 | core which includes a software model, derivied from the same code, 8 | for much easier (and faster) debugging. 9 | 10 | # New version 11 | 12 | The module Interp includes a reasonably well tested implementation 13 | of the bytecode instruction set. It is functorized 14 | and can execute bytecode programs or produce an AST. 15 | 16 | The executable implementation is useful for tracing bytecode programs, 17 | testing the implementation of the instruction set and, crucially, 18 | the included C-runtime. A fair amount of tracing functionality is 19 | included and can be compared to the traces generated by `ocamlrund`. 20 | Further, the OCaml REPL can be used as a simple debugger 21 | (`Framework.Interp.interactive`). 22 | 23 | The AST implementation records how machine registers are updated 24 | along with the memory accesses required. Such a sequence of 25 | operations covers much of the functionality of the instruction 26 | set. In addition we have loops, conditionals and some more 27 | abstract AST nodes to represent operations we want to defer the 28 | implementation of (c calls, oo method ops). 29 | 30 | This leads us to the current status of the project; compile the 31 | AST into hardware. 32 | 33 | The initial plan is to compile each instruction seperately into 34 | a statemachine (sequenced by memory accesses), and mux them together 35 | based on an instruction decoder. This should quickly lead to a 36 | working and pretty complete implementation. On the downside it 37 | will be a lot bigger and slower (frequency and cycles/instruction) 38 | than necessary. 39 | 40 | Various ongoing tasks to make this core useful include; 41 | 42 | * Port to FPGA - get something real working 43 | * Include RISC companion core for runtime 44 | * Analyse the AST to expose more efficient hardware implementations 45 | * Runtime 46 | * Improve simple version in `C\_runtime` 47 | * Port ocamlrun c-code and use that as the runtime 48 | * How much could be moved to ocaml code? 49 | * Garbage collector ... not looked at this at all yet. 50 | 51 | # Main modules 52 | 53 | * Machine - Types representing the ZINC machine 54 | * Load - Read bytecode, parse global data 55 | * Instr - Bytecode instruction set definitions 56 | * Mlvalues - Manipulating the OCaml representation of values 57 | * Trace - Debugging functions 58 | * Repr - Conversion of OCaml values to int64 arrays 59 | * Interp - Abstract implementation of bytecode instruction set 60 | * C\_runtime - Various functions from the interpreters C-runtime 61 | * Zinc - Old hardware implementation 62 | * Framework - Testbench and tracing 63 | 64 | # Old version 65 | 66 | **TO BE DEPRECIATED** 67 | 68 | Implemented as a large statemachine in `Zinc`. A major concern with this 69 | approach is the size of the statemachine - dozens of states so far, and 70 | a number of the more complex instructions still to go. A complete version 71 | would probably need hundreds of states which makes this approach a bit 72 | impractical. 73 | 74 | * **Status; says 'hello world!'** which actually exercises a pretty good chuck 75 | of the bytecode instruction set, and requires integration with a very basic 76 | (C-)runtime 77 | 78 | * Simulation only at the moment and will need some additions before a move 79 | to real hardware is worthwhile (proper memory interface - and probably 80 | caches - along with a more complete runtime system) 81 | 82 | * Currently only models a 64 bit OCaml ZAM as this matches my compiler. 83 | Should be fairly straight forward to model 32 bit as well. 84 | 85 | * Memory layout is shown below. A tiny c-heap is provided seperately for 86 | the c-runtime to simplify things for the time being. The ml-heap grows 87 | upwards and the stack starts at the top of memory and grows downwards. 88 | 89 | | Memory layout | 90 | |---------------| 91 | | program data | 92 | | atom table | 93 | | global data | 94 | | c-heap | 95 | | ml-heap | 96 | | stack | 97 | 98 | * No garbage collector for the time being. Will need to address this in stages; 99 | 1. unify the c and ml heaps and provide a general allocation procedure 100 | 2. some form of basic garbage collector implemented in the testbench so we 101 | can run bigger test cases 102 | 3. figure out what to do for an actual hardware system (lots of choices here 103 | as we can provide hardware assistance) 104 | 105 | * For C_CALLs the testbench intercepts the call and executes it with routines 106 | defined in C\_runtime. Hopefully there's a better way than just re-implementing 107 | lots and lots of OCaml C primitives here. 108 | 109 | * A number of instructions are not yet implemented - todo as testcases are found. 110 | 111 | -------------------------------------------------------------------------------- /archived/arbiter.ml: -------------------------------------------------------------------------------- 1 | (* round robin arbiter *) 2 | open Import 3 | open Stdio.Out_channel 4 | 5 | type 'a prefix = ('a -> 'a -> 'a) -> 'a list -> 'a list 6 | 7 | module Make (B : Comb.S) = struct 8 | open B 9 | 10 | let arbiter ~prefix ~unmasked_req ~masked_req = 11 | let sel_masked = tree ~arity:4 ~f:(reduce ~f:( |: )) (bits_msb masked_req) in 12 | let req = mux2 sel_masked masked_req unmasked_req in 13 | let mask, req = 14 | let mask = concat_msb @@ List.rev @@ prefix ( |: ) (List.rev (bits_msb req)) in 15 | let smask = sll mask 1 in 16 | smask &: req, mask ^: smask 17 | in 18 | mask, req 19 | ;; 20 | end 21 | 22 | open Signal 23 | 24 | let reg_spec = Reg_spec.create () ~clock ~clear 25 | 26 | let arbiter ~prefix ~enable ~req = 27 | let module A = Make (Signal) in 28 | let wreq = width req in 29 | let next = wire wreq in 30 | let masked_req = reg reg_spec ~enable next in 31 | let next', gnt = A.arbiter ~prefix ~unmasked_req:req ~masked_req in 32 | next <== next'; 33 | gnt 34 | ;; 35 | 36 | module Test = struct 37 | module B = Bits 38 | module Cs = Cyclesim 39 | module Waveform = Hardcaml_waveterm.Waveform 40 | 41 | let test ~prefix ~bits = 42 | let req = input "req" bits in 43 | let gnt = arbiter ~prefix ~enable:vdd ~req in 44 | let circ = Circuit.create_exn ~name:"arbiter" [ output "gnt" gnt ] in 45 | let sim = Cyclesim.create circ in 46 | let waves, sim = Waveform.create sim in 47 | let req, gnt, gntn = 48 | ( Cyclesim.in_port sim "req" 49 | , Cyclesim.out_port ~clock_edge:Before sim "gnt" 50 | , Cyclesim.out_port ~clock_edge:After sim "gnt" ) 51 | in 52 | Cyclesim.reset sim; 53 | for _ = 0 to 0 do 54 | req := B.random ~width:bits; 55 | while B.to_int !req <> 0 do 56 | printf "req: %s\n" (B.to_string !req); 57 | (*S.cycle_comb0 sim; 58 | S.cycle_seq sim; 59 | Printf.printf "gnt: %s\n" (B.to_string !gnt); 60 | S.cycle_comb1 sim;*) 61 | Cyclesim.cycle sim; 62 | printf "gnt: %s [%s]\n" (B.to_string !gnt) (B.to_string !gntn); 63 | req := B.(!req ^: !gnt) 64 | done 65 | done; 66 | Waveform.print waves 67 | ;; 68 | end 69 | -------------------------------------------------------------------------------- /archived/arbiter.mli: -------------------------------------------------------------------------------- 1 | open Hardcaml 2 | open Signal 3 | 4 | type 'a prefix = ('a -> 'a -> 'a) -> 'a list -> 'a list 5 | 6 | module Make (B : Comb.S) : sig 7 | val arbiter : prefix:B.t prefix -> unmasked_req:B.t -> masked_req:B.t -> B.t * B.t 8 | end 9 | 10 | val arbiter : prefix:t prefix -> enable:t -> req:t -> t 11 | 12 | module Test : sig 13 | val test : prefix:t prefix -> bits:int -> unit 14 | end 15 | -------------------------------------------------------------------------------- /archived/codes.ml: -------------------------------------------------------------------------------- 1 | (* build bytecodes by hand and debug the statemachine *) 2 | open Printf 3 | open HardCamlZinc 4 | 5 | let mk_exe code = { Load.empty with Load.code = Instr.to_array code } 6 | 7 | let run code = 8 | Framework.Testbench.make 9 | Framework.Testbench. 10 | { waves = true; instr_trace = true; state_trace = true; mem_trace = true } 11 | (mk_exe code) 12 | ;; 13 | 14 | let () = 15 | let open Instr in 16 | run 17 | [ const3 18 | ; push 19 | ; const1 20 | ; pushacc0 21 | ; constint 25l 22 | ; pushacc 0l 23 | ; pushconst2 24 | ; push 25 | ; constint 139l 26 | ; pushacc1 27 | ; stop 28 | ] 29 | ;; 30 | -------------------------------------------------------------------------------- /archived/hardcamlrun.ml: -------------------------------------------------------------------------------- 1 | (* hardcaml-zinc byte code runtime *) 2 | 3 | open Printf 4 | open HardCamlZinc 5 | 6 | let bytecode_filename = ref "" 7 | let waves = ref false 8 | let instr_trace = ref false 9 | let state_trace = ref false 10 | let mem_trace = ref false 11 | 12 | let () = 13 | Arg.parse 14 | [ "-i", Arg.Set_string bytecode_filename, " bytecode executable" 15 | ; "-waves", Arg.Set waves, " waveform viewer" 16 | ; "-t", Arg.Set instr_trace, " instruction trace" 17 | ; "-tt", Arg.Set state_trace, " detailed trace" 18 | ; "-ttt", Arg.Set mem_trace, " memory trace" 19 | ] 20 | (fun _ -> ()) 21 | "hardcamlrun (c) 2015 MicroJamJar Ltd" 22 | ;; 23 | 24 | let bytecode = Load.bytecode_exe !bytecode_filename 25 | 26 | (* show a few stats *) 27 | let () = 28 | let open Load in 29 | if !state_trace 30 | then ( 31 | printf "toc:\n"; 32 | List.iter (fun (n, l) -> printf " %s = %i\n" n l) bytecode.toc; 33 | printf "code = %i\n" (Array.length bytecode.code); 34 | printf "prims = %i\n" (Array.length bytecode.prim); 35 | Array.iteri (Printf.printf " [%i] %s\n") bytecode.prim; 36 | printf "**********************************\n\n") 37 | ;; 38 | 39 | let _ = 40 | let cfg = 41 | Framework.Testbench. 42 | { waves = !waves 43 | ; instr_trace = !instr_trace 44 | ; state_trace = !state_trace 45 | ; mem_trace = !mem_trace 46 | } 47 | in 48 | Framework.Testbench.make cfg bytecode 49 | ;; 50 | -------------------------------------------------------------------------------- /archived/simple.ml: -------------------------------------------------------------------------------- 1 | (* say hello world *) 2 | let () = output_string stderr "Hey! hello world from hardcamlzinc!\n" 3 | 4 | (*let a = 1 5 | let b = 2 6 | let c = a + b 7 | *) 8 | 9 | type foo = 10 | | X of int 11 | | Y of (int * int) 12 | | Z 13 | 14 | let x = 15 | List.fold_left 16 | (fun a -> function 17 | | X i -> a + i 18 | | Y (i, j) -> a + i + j 19 | | Z -> a + 1) 20 | 0 21 | [ X 1; Y (1, 2); Z; Z ] 22 | ;; 23 | 24 | (* switch instruction *) 25 | type t = 26 | | A 27 | | B 28 | | C 29 | 30 | let a = 31 | match A with 32 | | A -> 0 33 | | B -> 1 34 | | C -> 2 35 | ;; 36 | 37 | (* exceptions *) 38 | let () = 39 | try output_string stderr "not raised\n" with 40 | | _ -> output_string stderr "ooops\n" 41 | ;; 42 | 43 | let () = 44 | try raise Not_found with 45 | | Not_found -> output_string stderr "caught exn\n" 46 | ;; 47 | 48 | (* env vars *) 49 | let x = Sys.getenv "PATH" 50 | let () = prerr_endline x 51 | 52 | (* args *) 53 | let () = prerr_endline Sys.argv.(0) 54 | 55 | let () = 56 | try prerr_endline Sys.argv.(1) with 57 | | _ -> output_string stderr "no arg\n" 58 | ;; 59 | 60 | (* basic file I/O *) 61 | let f = open_in "tmp.in" 62 | let g = open_out "tmp.out" 63 | let s = input_line f 64 | let () = output_string g ("copied: " ^ s) 65 | let () = close_in f 66 | let () = close_out g 67 | 68 | (* closure stuff *) 69 | 70 | let n = 11 71 | 72 | let rec f i = 1 + if i < 0 then n else g (i - 1) 73 | and g i = f (i - 1) + f i 74 | 75 | let n = prerr_endline (string_of_int (f 3)) 76 | let () = output_string stderr "el finito!\n" 77 | 78 | (* string ops *) 79 | (* 80 | let s = Bytes.init 14 (fun i -> 'a') 81 | let () = Bytes.set s 3 'b' 82 | let () = Bytes.set s 12 'c' 83 | *) 84 | -------------------------------------------------------------------------------- /archived/zinc.ml: -------------------------------------------------------------------------------- 1 | (* hardcaml implementation of the zinc machine *) 2 | 3 | (* instructions todo; 4 | 5 | RETURN, RESTART, OFFSETCLOSURE, PUSHOFFSETCLOSURE 6 | 7 | PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS 8 | 9 | GETMETHOD, GETPUBMET, GETDYNMET 10 | 11 | EVENT, BREAK, RERAISE, RAISE_NOTRACE 12 | 13 | DIVINT, MODINT 14 | 15 | C_CALLN (part of decode.c_call) 16 | 17 | SWITCH (part of decode.branch) 18 | 19 | STOP (as part of callbacks) 20 | 21 | APPLY (decode.apply - APPLY1..3 ok) 22 | 23 | APPTERM (decode.appterm - APPTERM1..3 ok) 24 | 25 | GRAB (extra_args < required) 26 | 27 | MAKEFLOATBLOCK 28 | 29 | *) 30 | 31 | open Import 32 | open Signal 33 | 34 | let dbits = 64 35 | let bpw = dbits / 8 36 | let asft = Int.ceil_log2 bpw 37 | let reg_spec = Reg_spec.create () ~clock ~clear 38 | 39 | module Memory = struct 40 | module I = struct 41 | type 'a t = 42 | { (* memory data input *) 43 | memory_data_in : 'a [@bits dbits] 44 | ; (* memory data in ready *) 45 | memory_ready : 'a 46 | } 47 | [@@deriving sexp_of, hardcaml] 48 | end 49 | 50 | module O = struct 51 | type 'a t = 52 | { (* memory access request *) 53 | memory_request : 'a 54 | ; (* memory read/write *) 55 | memory_read_write : 'a 56 | ; (* memory address *) 57 | memory_address : 'a [@bits dbits] 58 | ; (* memory data out *) 59 | memory_data_out : 'a [@bits dbits] 60 | } 61 | [@@deriving sexp_of, hardcaml] 62 | end 63 | end 64 | 65 | (* arbitrate between the bytecode, stack and memory access interfaces *) 66 | let memory_if ~e ~stack_o ~bc_o ~mem_o ~ext_i = 67 | let open Memory.I in 68 | let open Memory.O in 69 | let open Always in 70 | let ( -- ) s n = s -- ("memory_if_" ^ n) in 71 | (* statemachine *) 72 | let module States = struct 73 | type t = 74 | | Request 75 | | Ready 76 | [@@deriving enumerate, compare, sexp_of] 77 | end 78 | in 79 | let { State_machine.is; switch = sm; set_next = next; _ } = 80 | State_machine.create (module States) ~enable:e reg_spec 81 | in 82 | (* arbitrate access to the memory interface *) 83 | let m = [ stack_o; bc_o; mem_o ] in 84 | let req = 85 | concat_lsb 86 | (List.map m ~f:(fun (x : Always.Variable.t Memory.O.t) -> x.memory_request.value)) 87 | in 88 | let gnt = 89 | let e = e &: is Request -- "arbiter_en" in 90 | let prefix f l = 91 | (* Parallel prefix networks are more efficient *) 92 | List.fold l ~init:[] ~f:(fun acc x -> 93 | match acc with 94 | | [] -> [ x ] 95 | | h :: t -> f x h :: h :: t) 96 | |> List.rev 97 | in 98 | Arbiter.arbiter ~prefix ~enable:e ~req 99 | in 100 | let gntb = onehot_to_binary gnt in 101 | let sel f = mux gntb (List.map m ~f) in 102 | let ext_o = 103 | { memory_data_out = sel (fun x -> x.memory_data_out.value) 104 | ; memory_read_write = sel (fun x -> x.memory_read_write.value) 105 | ; memory_address = sel (fun x -> x.memory_address.value) 106 | ; memory_request = sel (fun x -> x.memory_request.value) 107 | } 108 | in 109 | Always.( 110 | compile 111 | [ sm 112 | [ Request, [ when_ (req <>:. 0) [ next Ready ] ] 113 | ; Ready, [ when_ ext_i.memory_ready [ next Request ] ] 114 | ] 115 | ]); 116 | let stack_i, bc_i, mem_i = 117 | let mk i = 118 | { memory_data_in = ext_i.memory_data_in 119 | ; memory_ready = bit gnt i &: ext_i.memory_ready 120 | } 121 | in 122 | mk 0, mk 1, mk 2 123 | in 124 | ext_o, stack_i, bc_i, mem_i 125 | ;; 126 | 127 | module Decode = struct 128 | type 'a t = 129 | { acc : 'a 130 | ; acc_op : 'a 131 | ; push : 'a 132 | ; pushacc : 'a 133 | ; push_op : 'a 134 | ; pop : 'a 135 | ; assign : 'a 136 | ; envacc : 'a 137 | ; envacc_op : 'a 138 | ; pushenvacc : 'a 139 | ; pushenvacc_op : 'a 140 | ; push_retaddr : 'a 141 | ; apply : 'a 142 | ; apply_op : 'a 143 | ; appterm : 'a 144 | ; appterm_op : 'a 145 | ; closure : 'a 146 | ; closurerec : 'a 147 | ; return : 'a 148 | ; restart : 'a 149 | ; grab : 'a 150 | ; offsetclosure : 'a 151 | ; offsetclosure_op : 'a 152 | ; pushoffsetclosure : 'a 153 | ; pushoffsetclosure_op : 'a 154 | ; pushgetglobal : 'a 155 | ; getglobal : 'a 156 | ; pushgetglobalfield : 'a 157 | ; getglobalfield : 'a 158 | ; setglobal : 'a 159 | ; atom : 'a 160 | ; atom_op : 'a 161 | ; pushatom : 'a 162 | ; pushatom_op : 'a 163 | ; makeblock : 'a 164 | ; makeblock_op : 'a 165 | ; getfield : 'a 166 | ; getfield_op : 'a 167 | ; setfield : 'a 168 | ; setfield_op : 'a 169 | ; vectlength : 'a 170 | ; getvectitem : 'a 171 | ; setvectitem : 'a 172 | ; getstringchar : 'a 173 | ; setstringchar : 'a 174 | ; branch : 'a 175 | ; branch_op : 'a 176 | ; boolnot : 'a 177 | ; pushtrap : 'a 178 | ; poptrap : 'a 179 | ; raise_ : 'a 180 | ; check_signals : 'a 181 | ; c_call : 'a 182 | ; c_call_op : 'a 183 | ; const : 'a 184 | ; const_op : 'a 185 | ; pushconst : 'a 186 | ; pushconst_op : 'a 187 | ; alu : 'a 188 | ; alu_op : 'a 189 | ; comp : 'a 190 | ; comp_op : 'a 191 | ; offsetint : 'a 192 | ; offsetref : 'a 193 | ; isint : 'a 194 | ; getmethod : 'a 195 | ; bcomp : 'a 196 | ; bcomp_op : 'a 197 | ; ucomp : 'a 198 | ; ucomp_op : 'a 199 | ; bucomp : 'a 200 | ; bucomp_op : 'a 201 | ; getpubmet : 'a 202 | ; getdynmet : 'a 203 | ; stop : 'a 204 | ; event : 'a 205 | ; break : 'a 206 | ; reraise : 'a 207 | ; raise_notrace : 'a 208 | } 209 | [@@deriving sexp_of, hardcaml] 210 | end 211 | 212 | module I = struct 213 | type 'a t = 214 | { start : 'a 215 | ; bytecode_start_address : 'a [@bits dbits] 216 | ; atom_table_address : 'a [@bits dbits] 217 | ; globals_start_address : 'a [@bits dbits] 218 | ; heap_start_address : 'a [@bits dbits] 219 | ; stack_start_address : 'a [@bits dbits] 220 | ; memory_i : 'a Memory.I.t 221 | ; c_call_ready : 'a 222 | ; c_call_result : 'a [@bits dbits] 223 | } 224 | [@@deriving sexp_of, hardcaml] 225 | end 226 | 227 | module O = struct 228 | type 'a t = 229 | { state : 'a 230 | ; pc : 'a [@bits dbits] 231 | ; sp : 'a [@bits dbits] 232 | ; accu : 'a [@bits dbits] 233 | ; env : 'a [@bits dbits] 234 | ; extra_args : 'a [@bits dbits] 235 | ; instruction : 'a [@bits 8] 236 | ; error : 'a 237 | ; memory_o : 'a Memory.O.t 238 | ; decode : 'a Decode.t 239 | ; c_call_request : 'a 240 | ; c_call_prim : 'a [@bits dbits] 241 | } 242 | [@@deriving sexp_of, hardcaml] 243 | end 244 | 245 | type decinstr = 246 | { lte : t 247 | ; gte : t 248 | ; eq : t 249 | ; range : t 250 | } 251 | 252 | let decode instr = 253 | let constins i = consti ~width:8 (Opcode.to_int i) in 254 | let ins = Opcode.all in 255 | let sel = 256 | let sel = 257 | Array.of_list 258 | @@ List.map ins ~f:(fun i -> 259 | let i = constins i in 260 | { (* with some care perhaps we can use 1 subtractor for all this??? *) 261 | lte = instr <=: i 262 | ; gte = instr >=: i 263 | ; eq = instr ==: i 264 | ; range = instr -: i 265 | }) 266 | in 267 | fun i -> sel.(Opcode.to_int i) 268 | in 269 | let acc = (sel ACC).lte in 270 | let acc_op = (sel ACC0).range.:[3, 0] in 271 | let push = (sel PUSH).eq |: (sel PUSHACC0).eq in 272 | let pushacc = (sel PUSH).gte &: (sel PUSHACC).lte in 273 | let push_op = (sel PUSHACC0).range.:[3, 0] in 274 | let pop = (sel POP).eq in 275 | let assign = (sel ASSIGN).eq in 276 | let envacc = (sel ENVACC1).gte &: (sel ENVACC).lte in 277 | let envacc_op = (sel ENVACC1).range.:[2, 0] in 278 | let pushenvacc = (sel PUSHENVACC1).gte &: (sel PUSHENVACC).lte in 279 | let pushenvacc_op = (sel PUSHENVACC1).range.:[2, 0] in 280 | let push_retaddr = (sel PUSH_RETADDR).eq in 281 | let apply = (sel APPLY).gte &: (sel APPLY3).lte in 282 | let apply_op = (sel APPLY).range.:[1, 0] in 283 | let appterm = (sel APPTERM).gte &: (sel APPTERM3).lte in 284 | let appterm_op = (sel APPTERM).range.:[1, 0] in 285 | let closure = (sel CLOSURE).eq in 286 | let closurerec = (sel CLOSUREREC).eq in 287 | let return = (sel RETURN).eq in 288 | let restart = (sel RESTART).eq in 289 | let grab = (sel GRAB).eq in 290 | let pushgetglobal = (sel PUSHGETGLOBAL).eq in 291 | let getglobal = (sel GETGLOBAL).eq in 292 | let pushgetglobalfield = (sel PUSHGETGLOBALFIELD).eq in 293 | let getglobalfield = (sel GETGLOBALFIELD).eq in 294 | let setglobal = (sel SETGLOBAL).eq in 295 | let offsetclosure = (sel OFFSETCLOSUREM2).gte &: (sel OFFSETCLOSURE).lte in 296 | let offsetclosure_op = (sel OFFSETCLOSUREM2).range.:[1, 0] in 297 | let pushoffsetclosure = (sel PUSHOFFSETCLOSUREM2).gte &: (sel PUSHOFFSETCLOSURE).lte in 298 | let pushoffsetclosure_op = (sel PUSHOFFSETCLOSUREM2).range.:[1, 0] in 299 | let atom = (sel ATOM0).gte &: (sel ATOM).lte in 300 | let atom_op = (sel ATOM0).range.:[0, 0] in 301 | let pushatom = (sel PUSHATOM0).gte &: (sel PUSHATOM).lte in 302 | let pushatom_op = (sel PUSHATOM0).range.:[0, 0] in 303 | let makeblock = (sel MAKEBLOCK).gte &: (sel MAKEFLOATBLOCK).lte in 304 | let makeblock_op = (sel MAKEBLOCK).range.:[2, 0] in 305 | let getfield = (sel GETFIELD).gte &: (sel GETFLOATFIELD).lte in 306 | let getfield_op = (sel GETFIELD).range.:[2, 0] in 307 | let setfield = (sel SETFIELD).gte &: (sel SETFLOATFIELD).lte in 308 | let setfield_op = (sel SETFIELD).range.:[2, 0] in 309 | let vectlength = (sel VECTLENGTH).eq in 310 | let getvectitem = (sel GETVECTITEM).eq in 311 | let setvectitem = (sel SETVECTITEM).eq in 312 | let getstringchar = (sel GETSTRINGCHAR).eq in 313 | let setstringchar = (sel SETSTRINGCHAR).eq in 314 | let branch = (sel BRANCH).gte &: (sel SWITCH).lte in 315 | (* include switch? *) 316 | let branch_op = (sel BRANCH).range.:[1, 0] in 317 | let boolnot = (sel BOOLNOT).eq in 318 | let pushtrap = (sel PUSHTRAP).eq in 319 | let poptrap = (sel POPTRAP).eq in 320 | let raise_ = (sel RAISE).eq in 321 | let check_signals = (sel CHECK_SIGNALS).eq in 322 | let c_call = (sel C_CALL1).gte &: (sel C_CALLN).lte in 323 | let c_call_op = (sel C_CALL1).range.:[2, 0] in 324 | let const = (sel CONST0).gte &: (sel CONSTINT).lte in 325 | let const_op = (sel CONST0).range.:[2, 0] in 326 | let pushconst = (sel PUSHCONST0).gte &: (sel PUSHCONSTINT).lte in 327 | let pushconst_op = (sel PUSHCONST0).range.:[2, 0] in 328 | let alu = (sel NEGINT).gte &: (sel ASRINT).lte in 329 | let alu_op = (sel NEGINT).range.:[3, 0] in 330 | let comp = (sel EQ).gte &: (sel GEINT).lte in 331 | let comp_op = (sel EQ).range.:[2, 0] in 332 | let offsetint = (sel OFFSETINT).eq in 333 | let offsetref = (sel OFFSETREF).eq in 334 | let isint = (sel ISINT).eq in 335 | let getmethod = (sel GETMETHOD).eq in 336 | let bcomp = (sel BEQ).gte &: (sel BGEINT).lte in 337 | let bcomp_op = (sel BGEINT).range.:[2, 0] in 338 | let ucomp = (sel ULTINT).gte &: (sel UGEINT).lte in 339 | let ucomp_op = (sel ULTINT).range.:[0, 0] in 340 | let bucomp = (sel BULTINT).gte &: (sel BUGEINT).lte in 341 | let bucomp_op = (sel BULTINT).range.:[0, 0] in 342 | let getpubmet = (sel GETPUBMET).eq in 343 | let getdynmet = (sel GETDYNMET).eq in 344 | let stop = (sel STOP).eq in 345 | let event = (sel EVENT).eq in 346 | let break = (sel BREAK).eq in 347 | let reraise = (sel RERAISE).eq in 348 | let raise_notrace = (sel RAISE_NOTRACE).eq in 349 | Decode. 350 | { acc 351 | ; acc_op 352 | ; push 353 | ; pushacc 354 | ; push_op 355 | ; pop 356 | ; assign 357 | ; envacc 358 | ; envacc_op 359 | ; pushenvacc 360 | ; pushenvacc_op 361 | ; push_retaddr 362 | ; apply 363 | ; apply_op 364 | ; appterm 365 | ; appterm_op 366 | ; closure 367 | ; closurerec 368 | ; return 369 | ; restart 370 | ; grab 371 | ; offsetclosure 372 | ; offsetclosure_op 373 | ; pushoffsetclosure 374 | ; pushoffsetclosure_op 375 | ; pushgetglobal 376 | ; getglobal 377 | ; pushgetglobalfield 378 | ; getglobalfield 379 | ; setglobal 380 | ; atom 381 | ; atom_op 382 | ; pushatom 383 | ; pushatom_op 384 | ; makeblock 385 | ; makeblock_op 386 | ; getfield 387 | ; getfield_op 388 | ; setfield 389 | ; setfield_op 390 | ; vectlength 391 | ; getvectitem 392 | ; setvectitem 393 | ; getstringchar 394 | ; setstringchar 395 | ; branch 396 | ; branch_op 397 | ; boolnot 398 | ; pushtrap 399 | ; poptrap 400 | ; raise_ 401 | ; check_signals 402 | ; c_call 403 | ; c_call_op 404 | ; const 405 | ; const_op 406 | ; pushconst 407 | ; pushconst_op 408 | ; alu 409 | ; alu_op 410 | ; comp 411 | ; comp_op 412 | ; offsetref 413 | ; isint 414 | ; getmethod 415 | ; offsetint 416 | ; bcomp 417 | ; bcomp_op 418 | ; ucomp 419 | ; ucomp_op 420 | ; bucomp 421 | ; bucomp_op 422 | ; getpubmet 423 | ; getdynmet 424 | ; stop 425 | ; event 426 | ; break 427 | ; reraise 428 | ; raise_notrace 429 | } 430 | ;; 431 | 432 | let alu_int op a b = 433 | let a, b, z = msbs a, msbs b, zero (dbits - 1) in 434 | mux 435 | op 436 | [ z 437 | ; (* negate - 1 arg *) 438 | a +: b 439 | ; a -: b 440 | ; (a *+ b).:[dbits - 2, 0] 441 | ; z 442 | ; (* div - need iterative implementation *) 443 | z 444 | ; (* mod - need iterative implementation *) 445 | a &: b 446 | ; a |: b 447 | ; a ^: b 448 | ; log_shift sll a b.:[5, 0] 449 | ; (* XXX 64/32 *) 450 | log_shift srl a b.:[5, 0] 451 | ; log_shift sra a b.:[5, 0] 452 | ] 453 | @: vdd 454 | ;; 455 | 456 | let comp_int op a b = 457 | let a, b = msbs a, msbs b in 458 | zero (dbits - 2) @: mux op [ a ==: b; a <>: b; a <+ b; a <=+ b; a >+ b; a >=+ b ] @: vdd 459 | ;; 460 | 461 | let ucomp_int op a b = 462 | let a, b = msbs a, msbs b in 463 | zero (dbits - 2) @: mux op [ a <: b; a >: b ] @: vdd 464 | ;; 465 | 466 | module States = struct 467 | type t = 468 | [ `init 469 | | `fetch 470 | | `decode 471 | | `acc_set 472 | | `acc_offset 473 | | `pushacc 474 | | `envacc 475 | | `pop 476 | | `constint 477 | | `branch 478 | | `c_call0 479 | | `c_call1 480 | | `c_call2 481 | | `c_call3 482 | | `alu 483 | | `comp 484 | | `ucomp 485 | | `bcomp 486 | | `bucomp 487 | | `bcomp_setpc 488 | | `closure_nfuncs 489 | | `closure_nvars 490 | | `closure_alloc 491 | | `closure_var_start 492 | | `closure_var_read 493 | | `closure_var_write 494 | | `closure_func_start 495 | | `closure_func_hdr 496 | | `closure_func_pc 497 | | `closure_func_wpc 498 | | `closure_func_stack 499 | | `closure_accu_pc0 500 | | `closure_accu_pc1 501 | | `closure_accu_pc2 502 | | `setglobal 503 | | `getglobal_data 504 | | `getglobal 505 | | `getglobalfield_data 506 | | `getglobalfield 507 | | `makeblock 508 | | `makeblock_alloc 509 | | `makeblock_accu 510 | | `makeblock_read 511 | | `makeblock_write 512 | | `offsetint 513 | | `offsetref0 514 | | `offsetref1 515 | | `offsetref2 516 | | `atom 517 | | `apply_pop_stack 518 | | `apply_push_stack_env 519 | | `apply_push_stack_pc 520 | | `apply_push_stack_args 521 | | `apply_eargs 522 | | `apply 523 | | `appterm0 524 | | `appterm1 525 | | `appterm2 526 | | `appterm3 527 | | `appterm4 528 | | `grab 529 | | `push_retaddr0 530 | | `push_retaddr1 531 | | `push_retaddr2 532 | | `push_retaddr3 533 | | `vectlength 534 | | `getvectitem0 535 | | `getvectitem1 536 | | `setvectitem0 537 | | `setvectitem1 538 | | `setvectitem2 539 | | `getstringchar0 540 | | `getstringchar1 541 | | `setstringchar0 542 | | `setstringchar1 543 | | `setstringchar2 544 | | `setstringchar3 545 | | `not_implemented 546 | | `invalid_instruction 547 | ] 548 | [@@deriving sexp_of, compare, enumerate] 549 | end 550 | 551 | let state_str = List.map States.all ~f:(fun s -> Sexp.to_string_hum (States.sexp_of_t s)) 552 | 553 | module M = Mlvalues.Make (struct 554 | include Signal 555 | 556 | let ( /: ) _ _ = failwith "/:" 557 | let ( %: ) _ _ = failwith "%:" 558 | let const = consti ~width:dbits 559 | let zero = const 0 560 | let one = const 1 561 | let log_shift f a b = if Signal.is_const b then f a (to_int b) else log_shift f a b 562 | let sll a b = log_shift sll a b.:[5, 0] 563 | let srl a b = log_shift srl a b.:[5, 0] 564 | let sra a b = log_shift sra a b.:[5, 0] 565 | end) 566 | 567 | let zinc i = 568 | let open Memory.O in 569 | let open Memory.I in 570 | let open Decode in 571 | let open I in 572 | let open O in 573 | let open Always in 574 | let e = vdd in 575 | let ures x = uresize x dbits in 576 | let sres x = sresize x dbits in 577 | let val_int x = uresize x (dbits - 1) @: vdd in 578 | let val_unit = val_int (zero dbits) in 579 | let int_val x = sra x 1 in 580 | (* memory interface *) 581 | let stack_o = 582 | Memory.O.(map t ~f:(fun (_, b) -> Variable.reg ~enable:e reg_spec ~width:b)) 583 | in 584 | let mem_o = 585 | Memory.O.(map t ~f:(fun (_, b) -> Variable.reg ~enable:e reg_spec ~width:b)) 586 | in 587 | let bc_o = 588 | Memory.O.(map t ~f:(fun (_, b) -> Variable.reg ~enable:e reg_spec ~width:b)) 589 | in 590 | let memory_o, stack_i, bc_i, mem_i = 591 | memory_if ~e ~stack_o ~bc_o ~mem_o ~ext_i:i.memory_i 592 | in 593 | (* for 64 bit memory we need to extract the 32 bit bytecode value *) 594 | let bc_sel = Variable.reg reg_spec ~enable:e ~width:1 in 595 | let bc_i = 596 | { bc_i with 597 | memory_data_in = 598 | sres 599 | @@ mux2 bc_sel.value bc_i.memory_data_in.:[63, 32] bc_i.memory_data_in.:[31, 0] 600 | } 601 | in 602 | let pc = Variable.reg reg_spec ~enable:e ~width:dbits in 603 | (* code pointer *) 604 | let pc_next = pc.value +:. 4 in 605 | let sp = Variable.reg reg_spec ~enable:e ~width:dbits in 606 | (* stack pointer *) 607 | let accu = Variable.reg reg_spec ~enable:e ~width:dbits in 608 | (* accumulator *) 609 | let env = Variable.reg reg_spec ~enable:e ~width:dbits in 610 | (* heap-allocation environment *) 611 | let extra_args = Variable.reg reg_spec ~enable:e ~width:dbits in 612 | (* number of extra args provided by caller *) 613 | let error = Variable.reg reg_spec ~enable:e ~width:1 in 614 | let state = State_machine.create (module States) reg_spec ~enable:e in 615 | let n_temps = 3 in 616 | let temp = 617 | Array.init n_temps ~f:(fun i -> 618 | let g = Variable.reg reg_spec ~enable:e ~width:dbits in 619 | ignore (g.value -- ("temp_" ^ Int.to_string i) : Signal.t); 620 | g) 621 | in 622 | let clear_temps = proc (Array.to_list @@ Array.map temp ~f:(fun t -> t <--. 0)) in 623 | let shift_temp_up din = 624 | proc 625 | (Array.to_list 626 | @@ Array.init n_temps ~f:(fun i -> 627 | temp.(i) <-- if i = 0 then din else temp.(i - 1).value)) 628 | in 629 | let shift_temp_down din = 630 | proc 631 | (Array.to_list 632 | @@ Array.init n_temps ~f:(fun i -> 633 | temp.(i) <-- if i = n_temps - 1 then din else temp.(i + 1).value)) 634 | in 635 | let count = 636 | let r = Variable.reg reg_spec ~enable:e ~width:dbits in 637 | ignore (r.value -- "count" : Signal.t); 638 | r 639 | in 640 | let count_next = count.value +:. 1 -- "count_next" in 641 | let alloc_base = Variable.reg reg_spec ~enable:e ~width:dbits in 642 | let alloc_pointer = Variable.reg reg_spec ~enable:e ~width:dbits in 643 | let instruction = bc_i.memory_data_in.:[7, 0] in 644 | let decode = decode instruction in 645 | let decode' = 646 | let e = e &: state.is `decode in 647 | Decode.map decode ~f:(reg reg_spec ~enable:e) 648 | in 649 | let c_call_request = Variable.reg reg_spec ~enable:e ~width:1 in 650 | let c_call_prim = Variable.reg reg_spec ~enable:e ~width:dbits in 651 | (* functions for accessing memory *) 652 | let access_memif mem_i mem_o = 653 | let read addr nstate = 654 | proc 655 | [ mem_o.memory_address <-- addr 656 | ; mem_o.memory_request <--. 1 657 | ; mem_o.memory_read_write <--. 0 658 | ; state.set_next nstate 659 | ] 660 | in 661 | let write addr data nstate = 662 | proc 663 | [ mem_o.memory_address <-- addr 664 | ; mem_o.memory_data_out <-- data 665 | ; mem_o.memory_request <--. 1 666 | ; mem_o.memory_read_write <--. 1 667 | ; state.set_next nstate 668 | ] 669 | in 670 | let ready = 671 | let ready = ~:(mem_o.memory_request.value) |: mem_i.memory_ready in 672 | fun f -> when_ ready [ mem_o.memory_request <--. 0; proc (f mem_i.memory_data_in) ] 673 | in 674 | read, write, ready 675 | in 676 | (* reading bytecode *) 677 | let read_bytecode, when_bytecode_ready = 678 | let read, _, ready = access_memif bc_i bc_o in 679 | let pcaddr = pc.value.:[dbits - 1, asft] @: zero asft in 680 | let pcsel = pc.value.:[2, 2] in 681 | let read nstate = 682 | proc [ bc_sel <-- pcsel; (* XXX 64/32 *) read pcaddr nstate; pc <-- pc_next ] 683 | in 684 | read, ready 685 | in 686 | (* read and write general memory (ie the heaps, possible need to split into 687 | major and minor heaps *) 688 | let read_mem, write_mem, when_mem_ready = access_memif mem_i mem_o in 689 | let alloc_block col tag words rstate = 690 | proc 691 | [ write_mem alloc_base.value (M.make_header words col tag) rstate 692 | ; alloc_base <-- alloc_base.value +: sll (words +:. 1) asft 693 | ; alloc_pointer <-- alloc_base.value +:. bpw 694 | (* 1 past the header *) 695 | ] 696 | in 697 | let alloc_pointer_next = alloc_pointer.value +:. bpw in 698 | (* read and write the stack *) 699 | let read_stack, write_stack, when_stack_ready = access_memif stack_i stack_o in 700 | let push_stack = 701 | let sp_next = sp.value -:. bpw in 702 | fun data nstate -> proc [ write_stack sp_next data nstate; sp <-- sp_next ] 703 | in 704 | let pop_stack = 705 | let sp_next = sp.value +:. bpw in 706 | fun nstate -> proc [ read_stack sp.value nstate; sp <-- sp_next ] 707 | in 708 | let push_stack_accu = push_stack accu.value in 709 | let closure_nfuncs = temp.(0) in 710 | let closure_nvars = temp.(1) in 711 | let closure_base_pc = temp.(2) in 712 | let closure_nfuncs_offs = 713 | mux2 decode'.closure (one dbits) (sll (closure_nfuncs.value -- "nfuncs") 1 -:. 1) 714 | in 715 | let closure_blksize = closure_nfuncs_offs +: closure_nvars.value in 716 | let makeblock_wosize = temp.(0) in 717 | let makeblock_accu_base = temp.(1) in 718 | (* XXX stack argument should maybe be registered??? *) 719 | let alu_int = alu_int decode'.alu_op accu.value stack_i.memory_data_in in 720 | (* separate comp and bcomp as they take args in different orders. 721 | * I think we can optimise these functions so that these seperate 722 | * blocks are more efficient anyway *) 723 | let bcomp_int = (comp_int decode'.bcomp_op bc_i.memory_data_in accu.value).:[1, 1] in 724 | let bucomp_int = (ucomp_int decode'.bucomp_op bc_i.memory_data_in accu.value).:[1, 1] in 725 | let comp_int = comp_int decode'.comp_op accu.value stack_i.memory_data_in in 726 | let ucomp_int = ucomp_int decode'.ucomp_op accu.value stack_i.memory_data_in in 727 | let atom_ptr tag = i.atom_table_address +: sll tag asft in 728 | let aofs v = sll (uresize v dbits) 3 in 729 | let bcofs v = sll (uresize v dbits) 2 in 730 | let hdrp v = v +: aofs (consti ~width:dbits (-1)) in 731 | let get_byte s d = 732 | let f n = d.:[(8 * n) + 7, 8 * n] in 733 | mux s @@ Array.to_list @@ Array.init 8 ~f 734 | in 735 | let set_byte s d b = 736 | let f n = insert ~into:d b ~at_offset:(n * 8) in 737 | mux s @@ Array.to_list @@ Array.init 8 ~f 738 | in 739 | compile 740 | [ mem_o.memory_read_write <--. 0 741 | ; mem_o.memory_data_out <--. 0 742 | ; mem_o.memory_request <--. 0 743 | ; mem_o.memory_address <--. 0 744 | ; (* not used *) 745 | bc_o.memory_read_write <--. 0 746 | ; bc_o.memory_data_out <--. 0 747 | ; state.switch 748 | [ ( `init 749 | , [ accu <-- val_unit 750 | ; sp <-- i.stack_start_address 751 | ; pc <-- i.bytecode_start_address 752 | ; alloc_base <-- i.heap_start_address 753 | ; env <-- atom_ptr (zero dbits) 754 | ; extra_args <--. 0 755 | ; when_ i.start [ state.set_next `fetch ] 756 | ] ) 757 | ; (* fetch instruction *) 758 | ( `fetch 759 | , [ read_bytecode `decode; (* clear temporaries *) count <--. 0; clear_temps ] ) 760 | ; (* decode instruction *) 761 | ( `decode 762 | , [ when_bytecode_ready (fun _ -> 763 | [ if_ 764 | (reduce 765 | ~f:( |: ) 766 | [ (* try to catch stuff thats not implemented yet *) 767 | decode.return 768 | ; decode.restart 769 | ; decode.offsetclosure 770 | ; decode.pushoffsetclosure 771 | ; decode.pushtrap 772 | ; decode.poptrap 773 | ; decode.raise_ 774 | ; decode.check_signals 775 | ; decode.getmethod 776 | ; decode.getpubmet 777 | ; decode.getdynmet 778 | ; decode.event 779 | ; decode.break 780 | ; decode.reraise 781 | ; decode.raise_notrace 782 | ; decode.alu &: (decode.alu_op ==:. 4) 783 | ; (* DIVINT *) 784 | decode.alu &: (decode.alu_op ==:. 5) 785 | ; (* MODINT *) 786 | decode.c_call &: (decode.c_call_op ==:. 5) 787 | ; (* C_CALLN *) 788 | decode.branch &: (decode.branch_op ==:. 3) 789 | ; (* SWITCH *) 790 | decode.apply &: (decode.apply_op ==:. 0) 791 | ; (* APPLY *) 792 | decode.appterm &: (decode.appterm_op ==:. 0) 793 | ; (* APPTERM - not tested *) 794 | decode.makeblock &: (decode.makeblock_op ==:. 4) 795 | (* MAKEFLOATBLOCK *) 796 | ]) 797 | [ state.set_next `not_implemented ] 798 | (* branch instruction *) 799 | @@ elif 800 | decode.acc 801 | [ if_ 802 | (msb decode.acc_op) 803 | [ read_bytecode `acc_offset ] 804 | [ read_stack (sp.value +: aofs decode.acc_op) `acc_set ] 805 | ] 806 | (* push/acc/const *) 807 | @@ elif 808 | (decode.pushacc 809 | |: decode.pushconst 810 | |: decode.pushgetglobal 811 | |: decode.pushgetglobalfield 812 | |: decode.pushatom 813 | |: decode.pushenvacc) 814 | [ push_stack_accu `pushacc ] 815 | @@ elif 816 | decode.envacc 817 | [ read_mem (env.value +: aofs (decode.envacc_op +:. 1)) `envacc ] 818 | @@ elif 819 | decode.const 820 | [ if_ 821 | (msb decode.const_op) 822 | [ read_bytecode `constint ] 823 | [ accu <-- val_int decode.const_op; state.set_next `fetch ] 824 | ] 825 | (* branch *) 826 | @@ elif decode.branch [ read_bytecode `branch ] 827 | (* pop *) 828 | @@ elif decode.pop [ read_bytecode `pop ] 829 | (* alu *) 830 | @@ elif 831 | decode.alu 832 | [ if_ 833 | (decode.alu_op ==:. 0) 834 | [ (* only requires 1 operand *) 835 | accu <-- val_int (negate (msbs accu.value)) 836 | ; state.set_next `fetch 837 | ] 838 | [ (* 2 operands, through alu ... *) 839 | pop_stack `alu 840 | ; (* ... unless div or mod which need an iterative implementation *) 841 | when_ 842 | (decode.alu_op ==:. 4) 843 | [ state.set_next `invalid_instruction ] 844 | ; (* XXX todo *) 845 | when_ 846 | (decode.alu_op ==:. 5) 847 | [ state.set_next `invalid_instruction ] 848 | ] 849 | ] 850 | (* signed comparision *) 851 | @@ elif decode.comp [ pop_stack `comp ] 852 | @@ elif decode.ucomp [ pop_stack `ucomp ] 853 | @@ elif decode.bcomp [ read_bytecode `bcomp ] 854 | @@ elif decode.bucomp [ read_bytecode `bucomp ] 855 | (* offset *) 856 | @@ elif decode.offsetint [ read_bytecode `offsetint ] 857 | @@ elif decode.offsetref [ read_bytecode `offsetref0 ] 858 | @@ elif 859 | decode.isint 860 | [ accu <-- ures accu.value.:[0, 0]; state.set_next `fetch ] 861 | (* closure(rec) *) 862 | @@ elif decode.closure [ read_bytecode `closure_nvars ] 863 | @@ elif decode.closurerec [ read_bytecode `closure_nfuncs ] 864 | (* globals *) 865 | @@ elif decode.setglobal [ read_bytecode `setglobal ] 866 | @@ elif 867 | (decode.getglobal |: decode.getglobalfield) 868 | [ read_bytecode `getglobal_data ] 869 | (* makeblock *) 870 | @@ elif 871 | decode.makeblock 872 | [ if_ 873 | (decode.makeblock_op ==:. 0) 874 | [ read_bytecode `makeblock ] 875 | [ makeblock_wosize <-- ures decode.makeblock_op 876 | ; (* size *) 877 | read_bytecode `makeblock_alloc 878 | ] 879 | ] 880 | @@ elif decode.c_call [ push_stack env.value `c_call0 ] 881 | @@ elif 882 | decode.atom 883 | [ if_ 884 | decode.atom_op 885 | [ read_bytecode `atom ] 886 | [ state.set_next `atom ] 887 | ] 888 | @@ elif 889 | decode.apply 890 | [ if_ 891 | decode.apply_op 892 | [ state.set_next `apply_pop_stack ] 893 | [ read_bytecode `apply_eargs ] 894 | ] 895 | @@ elif 896 | decode.appterm 897 | [ if_ 898 | decode.appterm_op 899 | [ temp.(0) <-- ures decode.appterm_op 900 | ; read_bytecode `appterm1 901 | ] 902 | [ read_bytecode `appterm0 ] 903 | ] 904 | @@ elif decode.grab [ read_bytecode `grab ] 905 | @@ elif decode.stop [ state.set_next `invalid_instruction ] 906 | @@ elif decode.push_retaddr [ read_bytecode `push_retaddr0 ] 907 | @@ elif decode.vectlength [ read_mem (hdrp accu.value) `vectlength ] 908 | @@ elif decode.getvectitem [ pop_stack `getvectitem0 ] 909 | @@ elif decode.setvectitem [ pop_stack `setvectitem0 ] 910 | @@ elif decode.getstringchar [ pop_stack `getstringchar0 ] 911 | @@ elif decode.setstringchar [ pop_stack `setstringchar0 ] 912 | @@ elif 913 | decode.boolnot 914 | [ accu <-- val_int ~:(accu.value.:[1, 1]) 915 | ; state.set_next `fetch 916 | ] 917 | (* not implemented or invalid *) 918 | [ state.set_next `invalid_instruction ] 919 | ]) 920 | ] ) 921 | ; ( `acc_offset 922 | , [ when_bytecode_ready (fun offset -> 923 | [ read_stack (sp.value +: aofs offset) `acc_set ]) 924 | ] ) 925 | ; ( `acc_set 926 | , [ when_stack_ready (fun data -> [ accu <-- data; state.set_next `fetch ]) ] ) 927 | ; ( `pushacc 928 | , [ when_stack_ready (fun _ -> 929 | [ if_ 930 | decode'.pushconst 931 | [ if_ 932 | (msb decode'.pushconst_op) 933 | [ read_bytecode `constint ] 934 | [ accu <-- val_int decode'.pushconst_op; state.set_next `fetch ] 935 | ] 936 | @@ elif decode'.push [ state.set_next `fetch ] 937 | @@ elif 938 | decode'.pushenvacc 939 | [ read_mem 940 | (env.value +: aofs (decode'.pushenvacc_op +:. 1)) 941 | `envacc 942 | ] 943 | @@ elif 944 | (decode'.pushgetglobal |: decode'.pushgetglobalfield) 945 | [ read_bytecode `getglobal_data ] 946 | @@ elif 947 | decode'.pushatom 948 | [ if_ 949 | decode'.pushatom_op 950 | [ read_bytecode `atom ] 951 | [ state.set_next `atom ] 952 | ] 953 | [ if_ 954 | (msb decode'.push_op) 955 | [ read_bytecode `acc_offset ] 956 | [ read_stack (sp.value +: aofs decode'.push_op) `acc_set ] 957 | ] 958 | ]) 959 | ] ) 960 | ; ( `envacc 961 | , [ when_mem_ready (fun data -> 962 | [ accu <-- data 963 | ; state.set_next `fetch 964 | ; when_ 965 | (decode'.envacc 966 | &: (decode'.envacc_op ==:. 4) 967 | |: (decode'.pushenvacc &: (decode'.pushenvacc_op ==:. 4))) 968 | [ state.set_next `invalid_instruction (* not implemented yet! *) ] 969 | ]) 970 | ] ) 971 | ; ( `pop 972 | , [ when_bytecode_ready (fun offset -> 973 | [ sp <-- sp.value +: aofs offset; state.set_next `fetch ]) 974 | ] ) 975 | ; ( `constint 976 | , [ when_bytecode_ready (fun data -> 977 | [ accu <-- val_int data; state.set_next `fetch ]) 978 | ] ) 979 | ; (* perform branch *) 980 | ( `branch 981 | , [ when_bytecode_ready (fun data -> 982 | [ pc <-- pc.value +: bcofs (data -:. 1); state.set_next `fetch ]) 983 | ] ) 984 | ; (* alu *) 985 | ( `alu 986 | , [ when_stack_ready (fun _ -> [ accu <-- alu_int; state.set_next `fetch ]) ] ) 987 | ; (* comparison *) 988 | ( `comp 989 | , [ when_stack_ready (fun _ -> [ accu <-- comp_int; state.set_next `fetch ]) ] ) 990 | ; ( `ucomp 991 | , [ when_stack_ready (fun _ -> [ accu <-- ucomp_int; state.set_next `fetch ]) ] 992 | ) 993 | ; (* branch with comparison *) 994 | ( `bcomp 995 | , [ when_bytecode_ready (fun _ -> 996 | [ if_ 997 | bcomp_int 998 | [ read_bytecode `bcomp_setpc ] 999 | [ pc <-- pc_next; (* skip branch address *) state.set_next `fetch ] 1000 | ]) 1001 | ] ) 1002 | ; ( `bucomp 1003 | , [ when_bytecode_ready (fun _ -> 1004 | [ if_ 1005 | bucomp_int 1006 | [ read_bytecode `bcomp_setpc ] 1007 | [ pc <-- pc_next; state.set_next `fetch ] 1008 | ]) 1009 | ] ) 1010 | ; ( `bcomp_setpc 1011 | , [ when_bytecode_ready (fun data -> 1012 | [ pc <-- pc.value +: bcofs (data -:. 1); state.set_next `fetch ]) 1013 | ] ) 1014 | ; (* makeblock *) 1015 | ( `makeblock 1016 | , [ when_bytecode_ready (fun wosize -> 1017 | [ makeblock_wosize <-- wosize; read_bytecode `makeblock_alloc ]) 1018 | ] ) 1019 | ; ( `makeblock_alloc 1020 | , [ when_bytecode_ready (fun tag -> 1021 | [ alloc_block 1022 | M.black 1023 | (ures tag.:[7, 0]) 1024 | makeblock_wosize.value 1025 | `makeblock_accu 1026 | ]) 1027 | ] ) 1028 | ; ( `makeblock_accu 1029 | , [ when_mem_ready (fun _ -> 1030 | [ makeblock_accu_base <-- alloc_pointer.value 1031 | ; count <-- count_next 1032 | ; alloc_pointer <-- alloc_pointer_next 1033 | ; write_mem alloc_pointer.value accu.value `makeblock_read 1034 | ]) 1035 | ] ) 1036 | ; ( `makeblock_read 1037 | , [ when_mem_ready (fun _ -> 1038 | [ if_ 1039 | (count.value ==: makeblock_wosize.value) 1040 | [ accu <-- makeblock_accu_base.value; state.set_next `fetch ] 1041 | [ pop_stack `makeblock_write ] 1042 | ]) 1043 | ] ) 1044 | ; ( `makeblock_write 1045 | , [ when_stack_ready (fun data -> 1046 | [ count <-- count_next 1047 | ; alloc_pointer <-- alloc_pointer_next 1048 | ; write_mem 1049 | alloc_pointer.value 1050 | (mux2 (count.value ==:. 0) accu.value data) 1051 | `makeblock_read 1052 | ]) 1053 | ] ) 1054 | ; (* closure/closurerec *) 1055 | ( `closure_nfuncs 1056 | , [ when_bytecode_ready (fun data -> 1057 | [ closure_nfuncs <-- data; read_bytecode `closure_nvars ]) 1058 | ] ) 1059 | ; ( `closure_nvars 1060 | , [ when_bytecode_ready (fun data -> 1061 | [ closure_nvars <-- data 1062 | ; if_ 1063 | (data >:. 0) 1064 | [ push_stack_accu `closure_alloc ] 1065 | [ state.set_next `closure_alloc ] 1066 | ]) 1067 | ] ) 1068 | ; ( `closure_alloc 1069 | , [ when_stack_ready (fun _ -> 1070 | [ alloc_block M.black M.closure_tag closure_blksize `closure_var_start ]) 1071 | ] ) 1072 | ; ( `closure_var_start 1073 | , [ accu <-- alloc_pointer.value 1074 | ; when_mem_ready (fun _ -> 1075 | [ count <--. 0 1076 | ; if_ (closure_nvars.value <>:. 0) [ state.set_next `closure_var_read ] 1077 | @@ elif 1078 | decode'.closure 1079 | [ (* select CLOSURE/CLOSUREREC *) 1080 | read_bytecode `closure_accu_pc1 1081 | ] 1082 | [ state.set_next `closure_func_start ] 1083 | ]) 1084 | ] ) 1085 | ; ( `closure_var_read 1086 | , [ when_mem_ready (fun _ -> [ pop_stack `closure_var_write ]) ] ) 1087 | ; ( `closure_var_write 1088 | , [ when_stack_ready (fun data -> 1089 | let addr = 1090 | alloc_pointer.value +: aofs (count.value +: closure_nfuncs_offs) 1091 | in 1092 | [ write_mem addr data `closure_var_read 1093 | ; count <-- count_next 1094 | ; when_ 1095 | (count_next ==: closure_nvars.value) 1096 | [ if_ 1097 | decode'.closure 1098 | [ (* select CLOSURE/CLOSUREREC *) 1099 | state.set_next `closure_accu_pc0 1100 | ] 1101 | [ (* CLOSUREREC *) state.set_next `closure_func_start ] 1102 | ] 1103 | ]) 1104 | ] ) 1105 | ; (* setup 1st pass *) 1106 | ( `closure_func_start 1107 | , [ count <--. 0 1108 | ; closure_base_pc <-- pc.value 1109 | ; (* store base pc *) 1110 | when_mem_ready (fun _ -> [ read_bytecode `closure_func_wpc ]) 1111 | ] ) 1112 | ; (* write header *) 1113 | ( `closure_func_hdr 1114 | , let data = M.make_header (sll count.value 1) M.white M.infix_tag in 1115 | [ when_stack_ready (fun _ -> 1116 | [ alloc_pointer <-- alloc_pointer_next 1117 | ; if_ 1118 | (count.value ==: closure_nfuncs.value) 1119 | [ state.set_next `fetch ] 1120 | [ write_mem alloc_pointer.value data `closure_func_pc ] 1121 | ]) 1122 | ] ) 1123 | ; (* read bytecode *) 1124 | ( `closure_func_pc 1125 | , [ when_mem_ready (fun _ -> [ read_bytecode `closure_func_wpc ]) ] ) 1126 | ; (* write pc+pc[x] *) 1127 | ( `closure_func_wpc 1128 | , [ when_bytecode_ready (fun data -> 1129 | [ alloc_pointer <-- alloc_pointer_next 1130 | ; write_mem 1131 | alloc_pointer.value 1132 | (closure_base_pc.value +: bcofs data) 1133 | `closure_func_stack 1134 | ]) 1135 | ] ) 1136 | ; (* store to stack *) 1137 | ( `closure_func_stack 1138 | , let data = 1139 | mux2 1140 | (count.value ==:. 0) 1141 | accu.value 1142 | (alloc_pointer.value +: (aofs (sll count.value 1) +:. 1)) 1143 | (* XXX ??? *) 1144 | in 1145 | [ when_mem_ready (fun _ -> 1146 | [ count <-- count_next; push_stack data `closure_func_hdr ]) 1147 | ] ) 1148 | ; ( `closure_accu_pc0 1149 | , [ when_mem_ready (fun _ -> [ read_bytecode `closure_accu_pc1 ]) ] ) 1150 | ; ( `closure_accu_pc1 1151 | , [ when_bytecode_ready (fun ofs -> 1152 | [ write_mem accu.value (pc.value +: bcofs (ofs -:. 1)) `closure_accu_pc2 1153 | ]) 1154 | ] ) 1155 | ; `closure_accu_pc2, [ when_mem_ready (fun _ -> [ state.set_next `fetch ]) ] 1156 | ; (* globals *) 1157 | ( `setglobal 1158 | , [ when_bytecode_ready (fun ofs -> 1159 | [ write_mem (i.globals_start_address +: aofs ofs) accu.value `fetch 1160 | ; accu <-- val_unit 1161 | ]) 1162 | ] ) 1163 | ; ( `getglobal_data 1164 | , [ when_bytecode_ready (fun ofs -> 1165 | [ read_mem (i.globals_start_address +: aofs ofs) `getglobal ]) 1166 | ] ) 1167 | ; ( `getglobal 1168 | , [ when_mem_ready (fun data -> 1169 | [ accu <-- data 1170 | ; if_ 1171 | (decode'.getglobalfield |: decode'.pushgetglobalfield) 1172 | [ read_bytecode `getglobalfield_data ] 1173 | [ state.set_next `fetch ] 1174 | ]) 1175 | ] ) 1176 | ; ( `getglobalfield_data 1177 | , [ when_bytecode_ready (fun ofs -> 1178 | [ read_mem (accu.value +: aofs ofs) `getglobalfield ]) 1179 | ] ) 1180 | ; ( `getglobalfield 1181 | , [ when_mem_ready (fun data -> [ accu <-- data; state.set_next `fetch ]) ] ) 1182 | ; (* XXX TODO: C_CALLN *) 1183 | `c_call0, [ when_stack_ready (fun _ -> [ read_bytecode `c_call1 ]) ] 1184 | ; ( `c_call1 1185 | , [ when_bytecode_ready (fun prim -> 1186 | [ c_call_prim <-- prim 1187 | ; if_ 1188 | (decode'.c_call_op ==:. 5) 1189 | (* not implemented properly...stack=accu, multi args *) 1190 | [ state.set_next `invalid_instruction ] 1191 | (* XXX Somehow we need to do the C-call...through the c-testbench? *) 1192 | [ c_call_request <--. 1; state.set_next `c_call2 ] 1193 | ]) 1194 | ] ) 1195 | ; ( `c_call2 1196 | , [ when_ 1197 | i.c_call_ready 1198 | [ c_call_request <--. 0 1199 | ; accu <-- i.c_call_result 1200 | ; (* result of c-call *) 1201 | pop_stack `c_call3 1202 | ] 1203 | ] ) 1204 | ; ( `c_call3 1205 | , [ when_stack_ready (fun _ -> 1206 | [ sp <-- sp.value +: aofs decode'.c_call_op; state.set_next `fetch ]) 1207 | ] ) 1208 | ; ( `offsetint 1209 | , [ when_bytecode_ready (fun data -> 1210 | [ accu <-- accu.value +: sll data 1; state.set_next `fetch ]) 1211 | ] ) 1212 | ; ( `offsetref0 1213 | , [ when_bytecode_ready (fun data -> 1214 | [ temp.(0) <-- data; read_mem accu.value `offsetref1 ]) 1215 | ] ) 1216 | ; ( `offsetref1 1217 | , [ when_mem_ready (fun data -> 1218 | [ write_mem accu.value (data +: sll temp.(0).value 1) `offsetref2 ]) 1219 | ] ) 1220 | ; ( `offsetref2 1221 | , [ when_mem_ready (fun _ -> [ accu <-- val_unit; state.set_next `fetch ]) ] ) 1222 | ; ( `atom 1223 | , let get_tag ofs = 1224 | mux2 1225 | (decode'.atom 1226 | &: decode'.atom_op 1227 | |: (decode'.pushatom &: decode'.pushatom_op)) 1228 | ofs 1229 | (zero dbits) 1230 | in 1231 | [ when_bytecode_ready (fun ofs -> 1232 | [ accu <-- atom_ptr (get_tag ofs); state.set_next `fetch ]) 1233 | ] ) 1234 | ; (* applyX XXX TODO APPLY *) 1235 | ( `apply_pop_stack 1236 | , [ when_stack_ready (fun d -> 1237 | [ shift_temp_up d 1238 | ; count <-- count_next 1239 | ; if_ 1240 | (count.value ==: ures decode'.apply_op) 1241 | [ count <--. 0 1242 | ; push_stack (val_int extra_args.value) `apply_push_stack_env 1243 | ; extra_args <-- ures (decode'.apply_op -:. 1) 1244 | (* update extra_args *) 1245 | ] 1246 | [ pop_stack `apply_pop_stack ] 1247 | ]) 1248 | ] ) 1249 | ; ( `apply_push_stack_env 1250 | , [ when_stack_ready (fun _ -> [ push_stack env.value `apply_push_stack_pc ]) ] 1251 | ) 1252 | ; ( `apply_push_stack_pc 1253 | , [ when_stack_ready (fun _ -> [ push_stack pc.value `apply_push_stack_args ]) ] 1254 | ) 1255 | ; ( `apply_push_stack_args 1256 | , [ when_stack_ready (fun _ -> 1257 | [ shift_temp_down (zero dbits) 1258 | ; count <-- count_next 1259 | ; if_ 1260 | (count.value ==: ures decode'.apply_op) 1261 | [ read_mem accu.value `apply ] 1262 | [ push_stack temp.(0).value `apply_push_stack_args ] 1263 | ]) 1264 | ] ) 1265 | ; ( `apply_eargs 1266 | , [ when_bytecode_ready (fun earg -> 1267 | [ extra_args 1268 | <-- mux2 (decode'.apply_op ==:. 0) (earg -:. 1) (zero dbits) 1269 | ; pc <-- accu.value 1270 | ; (* XXX Code_val *) 1271 | state.set_next `fetch 1272 | ]) 1273 | ] ) 1274 | ; ( `apply 1275 | , [ when_mem_ready (fun pc' -> 1276 | [ pc <-- pc'; env <-- accu.value; state.set_next `fetch ]) 1277 | ] ) 1278 | ; (* APPTERM[x] *) 1279 | ( `appterm0 1280 | , [ when_bytecode_ready (fun nargs -> 1281 | [ temp.(0) <-- nargs; read_bytecode `appterm1 ]) 1282 | ] ) 1283 | ; ( `appterm1 1284 | , [ when_bytecode_ready (fun slotsize -> 1285 | [ temp.(1) <-- sp.value +: aofs (slotsize -: temp.(0).value) 1286 | ; count <-- temp.(0).value -:. 1 1287 | ; state.set_next `appterm2 1288 | ]) 1289 | ] ) 1290 | ; ( `appterm2 1291 | , [ (* read stack *) 1292 | when_stack_ready (fun _ -> 1293 | [ if_ 1294 | (count.value ==:. -1) 1295 | [ read_mem accu.value `appterm4 ] 1296 | [ read_stack (sp.value +: aofs count.value) `appterm3 ] 1297 | ]) 1298 | ] ) 1299 | ; ( `appterm3 1300 | , [ (* write stack *) 1301 | when_stack_ready (fun d -> 1302 | [ write_stack (temp.(1).value +: aofs count.value) d `appterm2 1303 | ; count <-- count.value -:. 1 1304 | ]) 1305 | ] ) 1306 | ; ( `appterm4 1307 | , [ when_mem_ready (fun pcn -> 1308 | [ sp <-- temp.(1).value 1309 | ; pc <-- pcn 1310 | ; env <-- accu.value 1311 | ; extra_args <-- extra_args.value +: temp.(0).value -:. 1 1312 | ; state.set_next `fetch 1313 | ]) 1314 | ] ) 1315 | ; ( `grab 1316 | , [ when_bytecode_ready (fun reqd -> 1317 | [ if_ 1318 | (extra_args.value >=: reqd) 1319 | [ extra_args <-- extra_args.value -: reqd; state.set_next `fetch ] 1320 | [ (* XXX TODO *) state.set_next `invalid_instruction ] 1321 | ]) 1322 | ] ) 1323 | ; ( `push_retaddr0 1324 | , [ when_bytecode_ready (fun ofs -> 1325 | [ push_stack (pc.value +: aofs ofs) `push_retaddr1 (* XXX ofs-1??? *) ]) 1326 | ] ) 1327 | ; ( `push_retaddr1 1328 | , [ when_stack_ready (fun _ -> [ push_stack env.value `push_retaddr2 ]) ] ) 1329 | ; ( `push_retaddr2 1330 | , [ when_stack_ready (fun _ -> 1331 | [ push_stack (val_int extra_args.value) `push_retaddr3 ]) 1332 | ] ) 1333 | ; `push_retaddr3, [ when_stack_ready (fun _ -> [ state.set_next `fetch ]) ] 1334 | ; ( `vectlength 1335 | , [ when_mem_ready (fun d -> 1336 | [ (* XXX; double??? *) accu <-- val_int (srl d 10) ]) 1337 | ] ) 1338 | ; ( `getvectitem0 1339 | , [ when_stack_ready (fun ofs -> 1340 | [ read_mem (accu.value +: aofs ofs) `getvectitem1 ]) 1341 | ] ) 1342 | ; ( `getvectitem1 1343 | , [ when_mem_ready (fun data -> [ accu <-- data; state.set_next `fetch ]) ] ) 1344 | ; ( `setvectitem0 1345 | , [ when_stack_ready (fun d -> [ temp.(0) <-- d; pop_stack `setvectitem1 ]) ] ) 1346 | ; ( `setvectitem1 1347 | , [ when_stack_ready (fun d -> 1348 | [ write_mem (accu.value +: aofs (int_val temp.(0).value)) d `fetch ]) 1349 | ] ) 1350 | ; ( `setvectitem2 1351 | , [ when_mem_ready (fun _ -> [ accu <-- val_unit; state.set_next `fetch ]) ] ) 1352 | ; ( `getstringchar0 1353 | , [ when_stack_ready (fun d -> 1354 | [ temp.(0) <-- d; read_mem accu.value `getstringchar1 ]) 1355 | ] ) 1356 | ; ( `getstringchar0 1357 | , [ when_stack_ready (fun d -> 1358 | [ accu <-- val_int @@ get_byte temp.(0).value.:[3, 1] d 1359 | ; state.set_next `fetch 1360 | ]) 1361 | ] ) 1362 | ; ( `setstringchar0 1363 | , [ when_stack_ready (fun d -> [ temp.(0) <-- d; pop_stack `setstringchar1 ]) ] 1364 | ) 1365 | ; ( `setstringchar1 1366 | , [ when_stack_ready (fun d -> 1367 | [ temp.(1) <-- d; read_mem accu.value `setstringchar2 ]) 1368 | ] ) 1369 | ; ( `setstringchar2 1370 | , [ when_mem_ready (fun d -> 1371 | [ write_mem 1372 | accu.value 1373 | (set_byte temp.(1).value.:[3, 1] d temp.(0).value.:[8, 1]) 1374 | `setstringchar3 1375 | ]) 1376 | ] ) 1377 | ; `setstringchar3, [ when_mem_ready (fun _ -> [ state.set_next `fetch ]) ] 1378 | ; (* invalid, or more likely not implemented yet *) 1379 | `not_implemented, [ error <--. 1 ] 1380 | ; `invalid_instruction, [ error <--. 1 ] 1381 | ] 1382 | ]; 1383 | { state = state.current 1384 | ; pc = pc.value 1385 | ; sp = sp.value 1386 | ; accu = accu.value 1387 | ; env = env.value 1388 | ; extra_args = extra_args.value 1389 | ; instruction = 1390 | mux2 (state.is `decode &: bc_i.memory_ready) instruction (consti ~width:8 255) 1391 | ; error = error.value 1392 | ; memory_o 1393 | ; decode = decode' 1394 | ; c_call_request = c_call_request.value 1395 | ; c_call_prim = c_call_prim.value 1396 | } 1397 | ;; 1398 | -------------------------------------------------------------------------------- /archived/zinc.mli: -------------------------------------------------------------------------------- 1 | module Memory : sig 2 | module I : sig 3 | type 'a t = 4 | { (* memory data input *) 5 | memory_data_in : 'a 6 | ; (* memory data in ready *) 7 | memory_ready : 'a 8 | } 9 | [@@deriving sexp_of, hardcaml] 10 | end 11 | 12 | module O : sig 13 | type 'a t = 14 | { (* memory access request *) 15 | memory_request : 'a 16 | ; (* memory read/write *) 17 | memory_read_write : 'a 18 | ; (* memory address *) 19 | memory_address : 'a 20 | ; (* memory data out *) 21 | memory_data_out : 'a 22 | } 23 | [@@deriving sexp_of, hardcaml] 24 | end 25 | end 26 | 27 | open Hardcaml 28 | open Signal 29 | 30 | val memory_if 31 | : e:t 32 | -> stack_o:Always.Variable.t Memory.O.t 33 | -> bc_o:Always.Variable.t Memory.O.t 34 | -> mem_o:Always.Variable.t Memory.O.t 35 | -> ext_i:t Memory.I.t 36 | -> t Memory.O.t * t Memory.I.t * t Memory.I.t * t Memory.I.t 37 | 38 | module Decode : Interface.S 39 | 40 | module I : sig 41 | type 'a t = 42 | { start : 'a 43 | ; bytecode_start_address : 'a 44 | ; atom_table_address : 'a 45 | ; globals_start_address : 'a 46 | ; heap_start_address : 'a 47 | ; stack_start_address : 'a 48 | ; memory_i : 'a Memory.I.t 49 | ; c_call_ready : 'a 50 | ; c_call_result : 'a 51 | } 52 | [@@deriving sexp_of, hardcaml] 53 | end 54 | 55 | module O : sig 56 | type 'a t = 57 | { state : 'a 58 | ; pc : 'a 59 | ; sp : 'a 60 | ; accu : 'a 61 | ; env : 'a 62 | ; extra_args : 'a 63 | ; instruction : 'a 64 | ; error : 'a 65 | ; memory_o : 'a Memory.O.t 66 | ; decode : 'a Decode.t 67 | ; c_call_request : 'a 68 | ; c_call_prim : 'a 69 | } 70 | [@@deriving sexp_of, hardcaml] 71 | end 72 | 73 | val state_str : string list 74 | val zinc : t I.t -> t O.t 75 | -------------------------------------------------------------------------------- /archived/zinc_tb.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Hardcaml 3 | module Waveform = Hardcaml_waveterm.Waveform 4 | module Z = Cyclesim.With_interface (Zinc.I) (Zinc.O) 5 | 6 | type cfg = 7 | { waves : bool 8 | ; instr_trace : bool 9 | ; state_trace : bool 10 | ; mem_trace : bool 11 | } 12 | 13 | let make cfg exe = 14 | let mem_size_words = 1024 * 1024 in 15 | let _show_instr = 16 | let ins = Base.List.map Opcode.all ~f:Opcode.to_string |> Base.Array.of_list in 17 | fun x -> 18 | let i = Bits.to_int x in 19 | try ins.(i) with 20 | | _ -> "" 21 | in 22 | (* let wave_cfg = 23 | * let f = function 24 | * | n, b -> if b = 1 then (n, Waveterm_waves.B) else (n, Waveterm_waves.H) 25 | * in 26 | * Some 27 | * ( [ 28 | * f ("clock", 1); 29 | * f ("clear", 1); 30 | * f ("enable", 1); 31 | * f ("start", 1); 32 | * f ("error", 1); 33 | * ("state", Waveterm_waves.I Zinc.state_str); 34 | * ("pc", Waveterm_waves.U); 35 | * ("instruction", Waveterm_waves.F show_instr); 36 | * ] 37 | * @ Zinc.I.(to_list @@ map t ~f) 38 | * @ Zinc.O.(to_list @@ map t ~f) 39 | * @ List.map 40 | * (fun s -> (s, Waveterm_waves.U)) 41 | * [ "nfuncs"; "nvars"; "count"; "count_next" ] ) 42 | * in *) 43 | let sim = Z.create Zinc.zinc in 44 | let waves, sim = 45 | if cfg.waves 46 | then ( 47 | let waves, sim = Waveform.create sim in 48 | Some waves, sim) 49 | else None, sim 50 | in 51 | let open Zinc.Memory.I in 52 | let open Zinc.Memory.O in 53 | let open Zinc.I in 54 | let open Zinc.O in 55 | let i = 56 | Zinc.I.map (Cyclesim.inputs sim) ~f:(fun i d -> 57 | i := Bits.consti ~width:(Bits.width !i) d) 58 | in 59 | let i64 = 60 | Zinc.I.map (Cyclesim.inputs sim) ~f:(fun i d -> 61 | i := Bits.consti64 ~width:(Bits.width !i) d) 62 | in 63 | let o = Zinc.O.map (Cyclesim.outputs sim) ~f:(fun o () -> Bits.to_int !o) in 64 | let n = 65 | Zinc.O.map (Cyclesim.outputs ~clock_edge:After sim) ~f:(fun o () -> Bits.to_int !o) 66 | in 67 | let n64 = 68 | Zinc.O.map (Cyclesim.outputs ~clock_edge:After sim) ~f:(fun o () -> Bits.to_int64 !o) 69 | in 70 | let o64 = 71 | Zinc.O.map (Cyclesim.outputs sim) ~f:(fun o () -> Bits.to_int !o |> Int64.of_int) 72 | in 73 | let mapping, memory = init_memory exe mem_size_words in 74 | let trace () = 75 | Trace.machine 76 | { Machine.empty with 77 | memory 78 | ; mapping 79 | ; env = o64.env () 80 | ; sp = o64.sp () 81 | ; accu = o64.sp () 82 | } 83 | in 84 | Cyclesim.reset sim; 85 | i.bytecode_start_address mapping.code_address; 86 | i.atom_table_address (mapping.atoms_address + 8); 87 | i.globals_start_address (mapping.globals_address + 8); 88 | i.heap_start_address mapping.heap_address; 89 | i.stack_start_address mapping.stack_address; 90 | i.start 1; 91 | let log_mem_access cycle rw addr data sp = 92 | if cfg.mem_trace 93 | then ( 94 | let offs, typ = 95 | if addr < mapping.atoms_address 96 | then (addr - 0) * 2, "BYTE" 97 | else if addr < mapping.globals_address 98 | then addr - mapping.atoms_address, "ATOM" 99 | else if addr < mapping.heap_address 100 | then addr - mapping.globals_address, "GLBL" 101 | else if addr >= sp - 8 102 | then mapping.stack_address - addr - 1, "STCK" 103 | else addr - mapping.heap_address, "HEAP" 104 | in 105 | printf 106 | "[%-8i] %s %s @[%.8x | %.8x] = %.16Lx [sp=%i]\n" 107 | cycle 108 | (if rw = 0 then "R" else "W") 109 | typ 110 | addr 111 | offs 112 | data 113 | sp) 114 | in 115 | let run () = 116 | let cycle = ref 0 in 117 | let stop = ref false in 118 | let instr_no = ref 1 in 119 | while (not !stop) && o.error () <> 1 do 120 | (* instruction trace *) 121 | if o.state () = 2 122 | then ( 123 | try 124 | if cfg.state_trace then printf "\n##%i\n" !instr_no; 125 | incr instr_no; 126 | if cfg.instr_trace 127 | then 128 | printf 129 | "%6i %s\n%!" 130 | ((o.pc () / 4) - 1) 131 | (o.instruction () |> Opcode.of_int |> Opcode.to_string); 132 | if cfg.state_trace then trace () 133 | with 134 | | _ -> 135 | stop := true; 136 | printf " INVALID\n%!"); 137 | Cyclesim.cycle sim; 138 | (* memory accesses *) 139 | i.memory_i.memory_ready 0; 140 | if n.memory_o.memory_request () <> 0 141 | then ( 142 | let addr = n.memory_o.memory_address () in 143 | let rw = n.memory_o.memory_read_write () in 144 | let sp = o.sp () in 145 | if rw = 0 146 | then ( 147 | (* read *) 148 | let data = memory.{addr lsr 3} in 149 | log_mem_access !cycle rw addr data sp; 150 | i64.memory_i.memory_data_in data) 151 | else ( 152 | (* write *) 153 | let data = n64.memory_o.memory_data_out () in 154 | log_mem_access !cycle rw addr data sp; 155 | memory.{addr lsr 3} <- data); 156 | i.memory_i.memory_ready 1); 157 | (* c-calls *) 158 | i.c_call_ready 0; 159 | if n.c_call_request () = 1 160 | then ( 161 | let prim = n.c_call_prim () in 162 | if cfg.instr_trace 163 | then Printf.printf "c_call_request: [%i]%s\n" prim exe.Load.prim.(prim); 164 | let value = 165 | match 166 | C_runtime.run 167 | exe 168 | prim 169 | { Machine.empty with 170 | Machine.env = o64.env () 171 | ; accu = o64.accu () 172 | ; sp = o64.sp () 173 | ; memory 174 | } 175 | with 176 | | `ok v -> v 177 | | `exn _ -> failwith "c-call exn not implemented" 178 | in 179 | i64.c_call_result value; 180 | i.c_call_ready 1); 181 | i.start 0; 182 | incr cycle 183 | done 184 | in 185 | let () = 186 | try run () with 187 | | Failure x -> printf "\n\nEXN: %s\n\n%!" x 188 | | _ -> printf "\n\nEXN %s\n\n%!" (Printexc.get_backtrace ()) 189 | in 190 | match waves with 191 | | None -> () 192 | | Some waves -> Hardcaml_waveterm_interactive.run waves 193 | ;; 194 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name monadinterp) 3 | (libraries compiler-libs.bytecomp hardcaml_zinc) 4 | ) -------------------------------------------------------------------------------- /bin/monadinterp.ml: -------------------------------------------------------------------------------- 1 | (* test the monadic interpreter *) 2 | open Printf 3 | open Hardcaml_zinc 4 | 5 | let bytecode_filename = ref "" 6 | 7 | let argv = ref [] 8 | 9 | let memsize_kb = ref 1024 10 | 11 | let num_instrs = ref (-1) 12 | 13 | let trace = ref 0 14 | 15 | (* 16 | let () = Arg.parse 17 | [ 18 | "-i", Arg.Set_string bytecode_filename, " bytecode executable"; 19 | "-m", Arg.Set_int memsize_kb, " memory size in Kb"; 20 | "-c", Arg.Set_int num_instrs, " number of instructions to run"; 21 | "-t", Arg.Unit (fun () -> incr trace), " increase trace level"; 22 | ] 23 | (fun _ -> ()) 24 | "monadinterp (c) 2015 MicroJamJar Ltd" 25 | *) 26 | 27 | let () = 28 | let run_args = ref [] in 29 | let rec anon_fun s = 30 | if !bytecode_filename = "" then ( 31 | bytecode_filename := s; 32 | run_args := 33 | [ ("-", Arg.String anon_fun, " arguments passed to inferior") ] ) 34 | else argv := s :: !argv 35 | in 36 | run_args := 37 | [ 38 | ("-m", Arg.Set_int memsize_kb, " memory size in Kb"); 39 | ("-c", Arg.Set_int num_instrs, " number of instructions to run"); 40 | ("-t", Arg.Unit (fun () -> incr trace), " increase trace level"); 41 | ]; 42 | Arg.parse_dynamic run_args anon_fun "monadinterp (c) 2015 MicroJamJar Ltd" 43 | 44 | let () = if !bytecode_filename = "" then failwith "No bytecode file specified" 45 | 46 | let () = 47 | C_runtime.argv := 48 | (!bytecode_filename, Array.of_list (!bytecode_filename :: List.rev !argv)) 49 | 50 | let bytecode = Load.bytecode_exe !bytecode_filename 51 | 52 | let mapping, memory = Framework.init_memory bytecode (!memsize_kb * (1024 / 8)) 53 | 54 | let state = Framework.init_state mapping memory bytecode 55 | 56 | let () = if !trace > 2 then Trace.showfields := true 57 | 58 | let rec run n st = 59 | if n = !num_instrs then () 60 | else 61 | let () = if !trace > 1 then printf "\n##%i\n" (n + 1) in 62 | match Framework.Interp.step ~trace:!trace st with 63 | | Some st -> run (n + 1) st 64 | | None -> () 65 | 66 | let () = run 0 state 67 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) -------------------------------------------------------------------------------- /hardcaml_zinc.opam: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ujamjar/hardcaml-zinc/ad9360a66ddd239550623e3a92fe5328934706fa/hardcaml_zinc.opam -------------------------------------------------------------------------------- /src/c_runtime.ml: -------------------------------------------------------------------------------- 1 | (* c-runtime hacks *) 2 | open Base 3 | open Machine 4 | module Obj = Caml.Obj 5 | module Parsing = Caml.Parsing 6 | 7 | type open_flag = Caml.open_flag 8 | 9 | let in_channel_length = Caml.in_channel_length 10 | let input = Caml.input 11 | let input_value = Caml.input_value 12 | let seek_in = Caml.seek_in 13 | let pos_in = Caml.pos_in 14 | let input_char = Caml.input_char 15 | let input_binary_int = Caml.input_binary_int 16 | let close_in = Caml.close_in 17 | let out_channel_length = Caml.out_channel_length 18 | let seek_out = Caml.seek_out 19 | let output_char = Caml.output_char 20 | let output_substring = Caml.output_substring 21 | let close_out = Caml.close_out 22 | let flush = Caml.flush 23 | 24 | type result = (Int64.t, Int64.t) Result.t 25 | 26 | type c_call = 27 | | C1 of (state -> int64 -> result) 28 | | C2 of (state -> int64 -> int64 -> result) 29 | | C3 of (state -> int64 -> int64 -> int64 -> result) 30 | | C4 of (state -> int64 -> int64 -> int64 -> int64 -> result) 31 | | C5 of (state -> int64 -> int64 -> int64 -> int64 -> int64 -> result) 32 | | CN 33 | 34 | type std_exn = 35 | | OUT_OF_MEMORY_EXN (* "Out_of_memory" *) 36 | | SYS_ERROR_EXN (* "Sys_error" *) 37 | | FAILURE_EXN (* "Failure" *) 38 | | INVALID_EXN (* "Invalid_argument" *) 39 | | END_OF_FILE_EXN (* "End_of_file" *) 40 | | ZERO_DIVIDE_EXN (* "Division_by_zero" *) 41 | | NOT_FOUND_EXN (* "Not_found" *) 42 | | MATCH_FAILURE_EXN (* "Match_failure" *) 43 | | STACK_OVERFLOW_EXN (* "Stack_overflow" *) 44 | | SYS_BLOCKED_IO (* "Sys_blocked_io" *) 45 | | ASSERT_FAILURE_EXN (* "Assert_failure" *) 46 | | UNDEFINED_RECURSIVE_MODULE_EXN (* "Undefined_recursive_module" *) 47 | [@@deriving sexp_of, variants] 48 | 49 | open Ops.Int64 50 | include Mlvalues.Make (Ops.Int64) 51 | 52 | (* maintain a small seperate heap section of c-allocation *) 53 | let c_heap_address = ref 0 54 | let c_heap_address_max = ref 0 55 | 56 | let init addr size = 57 | c_heap_address := addr / 8; 58 | c_heap_address_max := !c_heap_address + (size / 8) 59 | ;; 60 | 61 | let bump size = 62 | c_heap_address := !c_heap_address + size; 63 | (*Printf.printf "C_runtime.bump %i %x\n" size (!c_heap_address * 8);*) 64 | if not (!c_heap_address <= !c_heap_address_max) then failwith "c-heap out of memory" 65 | ;; 66 | 67 | (* alplocate a block in the c-heap. *) 68 | let alloc_block ~st ~size ~colour ~tag = 69 | let p = !c_heap_address in 70 | bump (Int64.to_int_exn size + 1); 71 | st.memory.{p} <- make_header size colour tag; 72 | Int64.of_int ((p + 1) * 8) 73 | ;; 74 | 75 | exception Get_repr 76 | exception Get_obj 77 | exception Alloc_block_from 78 | 79 | let get_repr : ?closure:bool -> 'a -> int -> int64 array = 80 | fun ?(closure = true) a ofs -> 81 | try Repr.to_data64 (Repr.of_obj ~closure (Obj.repr a)) ofs with 82 | | _ -> raise Get_repr 83 | ;; 84 | 85 | let get_obj : ?closure:bool -> state -> int64 -> 'a = 86 | fun ?(closure = true) st p -> 87 | try Obj.magic (Repr.to_obj (Repr.of_data64 ~closure st.memory p)) with 88 | | _ -> raise Get_obj 89 | ;; 90 | 91 | let alloc_block_from : state -> 'a -> int64 = 92 | fun st a -> 93 | try 94 | let p = !c_heap_address in 95 | let a = get_repr a p in 96 | let size = Array.length a in 97 | if size = 1 98 | then a.(0) (* must be a scalar value *) 99 | else ( 100 | bump size; 101 | for i = 0 to size - 1 do 102 | st.memory.{i + p} <- a.(i) 103 | done; 104 | Int64.of_int ((p + 1) * 8)) 105 | with 106 | | _ -> raise Alloc_block_from 107 | ;; 108 | 109 | let header st v = st.memory.{(Int64.to_int_exn v / 8) - 1} 110 | let field st v i = st.memory.{(Int64.to_int_exn v / 8) + i} 111 | let set_field st v i d = st.memory.{(Int64.to_int_exn v / 8) + i} <- d 112 | let set_header st v d = set_field st v (-1) d 113 | let modify = set_field 114 | let c1_unit = C1 (fun _ _ -> Ok val_unit) 115 | let c2_unit = C2 (fun _ _ _ -> Ok val_unit) 116 | let _c3_unit = C3 (fun _ _ _ _ -> Ok val_unit) 117 | let _c4_unit = C4 (fun _ _ _ _ _ -> Ok val_unit) 118 | let _c5_unit = C5 (fun _ _ _ _ _ _ -> Ok val_unit) 119 | let _c1_id = C1 (fun _ a -> Ok a) 120 | let c1_int i = C1 (fun _ _ -> Ok (val_int i)) 121 | let c2_int i = C2 (fun _ _ _ -> Ok (val_int i)) 122 | let c1_true = C1 (fun _ _ -> Ok val_true) 123 | let c1_false = C1 (fun _ _ -> Ok val_false) 124 | 125 | let caml_copy_string st s = 126 | let size = size (header st s) in 127 | let p = alloc_block ~st ~size ~colour:white ~tag:string_tag in 128 | for i = 0 to Int64.to_int_exn size - 1 do 129 | set_field st p i (field st s i) 130 | done; 131 | p 132 | ;; 133 | 134 | let caml_copy_string' st s = 135 | let s = Obj.repr s in 136 | let size = Obj.size s in 137 | let p = alloc_block ~st ~size:(Int64.of_int size) ~colour:white ~tag:string_tag in 138 | for i = 0 to size - 1 do 139 | set_field st p i (Repr.int64_of_obj (Obj.field s i)) 140 | done; 141 | p 142 | ;; 143 | 144 | (* exceptions (fail.c) *) 145 | let caml_raise _ v = Error v 146 | let caml_raise_constant = caml_raise 147 | 148 | let caml_raise_with_arg st tag arg = 149 | let p = alloc_block ~st ~size:2L ~colour:white ~tag:0L in 150 | set_field st p 0 tag; 151 | set_field st p 1 arg; 152 | caml_raise st p 153 | ;; 154 | 155 | let caml_raise_with_string st tag s = 156 | let s' = caml_copy_string st s in 157 | caml_raise_with_arg st tag s' 158 | ;; 159 | 160 | let caml_raise_with_string' st tag s = 161 | let s' = caml_copy_string' st s in 162 | caml_raise_with_arg st tag s' 163 | ;; 164 | 165 | let exn_field st x = field st st.global_data (Variants_of_std_exn.to_rank x) 166 | let _caml_failwith st s = caml_raise_with_string st (exn_field st FAILURE_EXN) s 167 | let _caml_invalid_argument st s = caml_raise_with_string st (exn_field st INVALID_EXN) s 168 | let caml_invalid_argument' st s = caml_raise_with_string' st (exn_field st INVALID_EXN) s 169 | let caml_array_bound_error st = caml_invalid_argument' st "index out of bounds" 170 | let _caml_raise_out_of_memory st = caml_raise_constant st (exn_field st OUT_OF_MEMORY_EXN) 171 | 172 | let _caml_raise_stack_overflow st = 173 | caml_raise_constant st (exn_field st STACK_OVERFLOW_EXN) 174 | ;; 175 | 176 | let _caml_raise_sys_error st s = caml_raise_with_arg st (exn_field st SYS_ERROR_EXN) s 177 | let caml_raise_sys_error' st s = caml_raise_with_string' st (exn_field st SYS_ERROR_EXN) s 178 | let _caml_raise_end_of_file st = caml_raise_constant st (exn_field st END_OF_FILE_EXN) 179 | let _caml_raise_zero_divide st = caml_raise_constant st (exn_field st ZERO_DIVIDE_EXN) 180 | let caml_raise_not_found st = caml_raise_constant st (exn_field st NOT_FOUND_EXN) 181 | let _caml_raise_sys_blocked_io st = caml_raise_constant st (exn_field st SYS_BLOCKED_IO) 182 | 183 | let _caml_is_special_exception st exn = 184 | Int64.equal exn (exn_field st MATCH_FAILURE_EXN) 185 | || Int64.equal exn (exn_field st ASSERT_FAILURE_EXN) 186 | || Int64.equal exn (exn_field st UNDEFINED_RECURSIVE_MODULE_EXN) 187 | ;; 188 | 189 | let aofs x = sll x 3L 190 | 191 | let caml_alloc st size tag = 192 | if Int64.equal size 0L 193 | then st.atom_table +: aofs tag 194 | else ( 195 | let p = alloc_block ~st ~size ~colour:white ~tag in 196 | if Int64.equal (tag <+ no_scan_tag) 1L 197 | then 198 | for i = 0 to Int64.to_int_exn size - 1 do 199 | set_field st p i val_unit 200 | done; 201 | p) 202 | ;; 203 | 204 | let caml_alloc_dummy = C1 (fun st size -> Ok (caml_alloc st (int_val size) 0L)) 205 | 206 | let caml_update_dummy = 207 | C2 208 | (fun st dummy newval -> 209 | let hdummy = header st dummy in 210 | let hnewval = header st newval in 211 | assert (Int64.equal (size hdummy) (size hnewval)); 212 | assert ( 213 | Int64.compare (tag newval) no_scan_tag < 0 214 | || Int64.equal (tag newval) double_array_tag); 215 | set_header st dummy (make_header (size hdummy) (colour hdummy) (tag hnewval)); 216 | for i = 0 to Int64.to_int_exn (size hdummy) - 1 do 217 | modify st dummy i (field st newval i) 218 | done; 219 | Ok val_unit) 220 | ;; 221 | 222 | let caml_fresh_oo_id, caml_set_oo_id = 223 | let c = ref 1L in 224 | ( C1 225 | (fun _ _ -> 226 | let oo_id = !c in 227 | c := !c +: 2L; 228 | Ok oo_id) 229 | , C1 230 | (fun st ptr -> 231 | set_field st ptr 1 !c; 232 | c := !c +: 2L; 233 | Ok ptr) ) 234 | ;; 235 | 236 | let caml_get_section_table = C1 (fun st _ -> caml_raise_not_found st) 237 | 238 | let caml_int64_float_of_bits = 239 | C1 240 | (fun st v -> 241 | let p = alloc_block ~st ~size:1L ~colour:black ~tag:double_tag in 242 | set_field st p 0 (field st v 1); 243 | Ok p) 244 | ;; 245 | 246 | let file_descrs = ref [] 247 | let add_descr fd chan ptr = file_descrs := (fd, (chan, ptr)) :: !file_descrs 248 | 249 | let remove_descr fd = 250 | file_descrs := List.filter !file_descrs ~f:(fun (fd', _) -> not (Int64.equal fd' fd)) 251 | ;; 252 | 253 | let descr_block st fd = 254 | let p = alloc_block ~st ~size:2L ~colour:white ~tag:custom_tag in 255 | (* int * int, fd is second field *) 256 | set_field st p 0 1L; 257 | set_field st p 1 fd; 258 | p 259 | ;; 260 | 261 | let get_descr fd = 262 | (* XXX assumption; file_descr <=> int *) 263 | let fd : int = Int64.to_int_exn (int_val fd) in 264 | (Obj.magic fd : Unix.file_descr) 265 | ;; 266 | 267 | let find_chan st p = 268 | match List.Assoc.find ~equal:Int64.equal !file_descrs (field st p 1) with 269 | | Some x -> x 270 | | None -> failwith ("in channel not found (" ^ Int64.to_string (field st p 1) ^ ")") 271 | ;; 272 | 273 | let unlink_chan st p = 274 | let f = find_chan st p in 275 | remove_descr (field st p 1); 276 | f 277 | ;; 278 | 279 | let find_chan_in st p = 280 | match find_chan st p with 281 | | `i f, _ -> f 282 | | _ -> raise Caml.Not_found 283 | ;; 284 | 285 | let find_chan_out st p = 286 | match find_chan st p with 287 | | `o f, _ -> f 288 | | _ -> raise Caml.Not_found 289 | ;; 290 | 291 | let caml_ml_open_descriptor_in = 292 | C1 293 | (fun st fd -> 294 | let fd' = get_descr fd in 295 | let p = descr_block st fd in 296 | add_descr fd (`i (Unix.in_channel_of_descr fd')) p; 297 | Ok p) 298 | ;; 299 | 300 | let caml_ml_open_descriptor_out = 301 | C1 302 | (fun st fd -> 303 | let fd' = get_descr fd in 304 | let p = descr_block st fd in 305 | add_descr fd (`o (Unix.out_channel_of_descr fd')) p; 306 | Ok p) 307 | ;; 308 | 309 | let caml_ml_close_channel = 310 | C1 311 | (fun st fd -> 312 | (match unlink_chan st fd with 313 | (* raise exn? *) 314 | | `i f, _ -> close_in f 315 | | `o f, _ -> close_out f); 316 | Ok val_unit) 317 | ;; 318 | 319 | let mk_list st l = 320 | List.fold_right l ~init:(val_int 0L) ~f:(fun p l -> 321 | let x = alloc_block ~st ~size:2L ~tag:0L ~colour:white in 322 | set_field st x 0 p; 323 | set_field st x 1 l; 324 | x) 325 | ;; 326 | 327 | let caml_ml_out_channels_list = 328 | C1 329 | (fun st _ -> 330 | let l = 331 | List.filter !file_descrs ~f:(function 332 | | _, (`o _, _) -> true 333 | | _ -> false) 334 | in 335 | let l = List.map l ~f:(fun (_, (_, p)) -> p) in 336 | Ok (mk_list st l)) 337 | ;; 338 | 339 | let caml_ml_output_char = 340 | C2 341 | (fun st chan c -> 342 | output_char (find_chan_out st chan) (Char.of_int_exn (Int64.to_int_exn (int_val c))); 343 | Ok val_unit) 344 | ;; 345 | 346 | let caml_ml_flush = 347 | C1 348 | (fun st chan -> 349 | let chan = find_chan_out st chan in 350 | flush chan; 351 | Ok val_unit) 352 | ;; 353 | 354 | let string_length st v = 355 | assert (Int64.equal string_tag (tag (header st v))); 356 | let size = Int64.to_int_exn @@ size (header st v) in 357 | let pad = Int64.to_int_exn @@ Int64.shift_right_logical (field st v (size - 1)) 56 in 358 | Int64.of_int @@ ((size * 8) - pad - 1) 359 | ;; 360 | 361 | let caml_ml_string_length = C1 (fun st v -> Ok (val_int @@ string_length st v)) 362 | let get_string st v = (get_obj st v : string) 363 | 364 | let caml_ml_output = 365 | C4 366 | (fun st chan bytes ofs len -> 367 | let str = get_string st bytes in 368 | output_substring 369 | (find_chan_out st chan) 370 | str 371 | (Int64.to_int_exn @@ int_val ofs) 372 | (Int64.to_int_exn @@ int_val len); 373 | Ok val_unit) 374 | ;; 375 | 376 | let caml_ml_input_scan_line = 377 | C1 378 | (fun st fd -> 379 | let chan = find_chan_in st fd in 380 | let pos = pos_in chan in 381 | let rec f n = 382 | try if Char.equal (input_char chan) '\n' then n + 1 else f (n + 1) with 383 | | _ -> -n 384 | in 385 | let n = f 0 in 386 | let () = seek_in chan pos in 387 | (* restore file pos (I think) *) 388 | Ok (val_int (Int64.of_int n))) 389 | ;; 390 | 391 | let caml_ml_seek_in = 392 | C2 393 | (fun st chan pos -> 394 | try 395 | seek_in (find_chan_in st chan) (Int64.to_int_exn (int_val pos)); 396 | Ok val_unit 397 | with 398 | | _ -> caml_raise_sys_error' st "caml_ml_seek_in") 399 | ;; 400 | 401 | let caml_ml_seek_out = 402 | C2 403 | (fun st chan pos -> 404 | try 405 | seek_out (find_chan_out st chan) (Int64.to_int_exn (int_val pos)); 406 | Ok val_unit 407 | with 408 | | _ -> caml_raise_sys_error' st "caml_ml_seek_out") 409 | ;; 410 | 411 | let set_byte' st s ofs b = 412 | let w = field st s (ofs / 8) in 413 | let sft = Int64.of_int (ofs land 7 * 8) in 414 | let mask = ~:(sll 255L sft) in 415 | let b = sll (b &: 255L) sft in 416 | set_field st s (ofs / 8) (w &: mask |: b) 417 | ;; 418 | 419 | let set_byte st s ofs b = set_byte' st s ofs (Int64.of_int (Char.to_int b)) 420 | 421 | let get_byte st s ofs = 422 | let w = field st s (ofs / 8) in 423 | let sft = Int64.of_int (ofs land 7 * 8) in 424 | srl w sft &: 255L 425 | ;; 426 | 427 | let caml_string_get = 428 | C2 429 | (fun st s i -> 430 | let i = int_val i in 431 | if Int64.compare i 0L < 0 || Int64.compare i (string_length st s) >= 0 432 | then caml_array_bound_error st 433 | else Ok (val_int (get_byte st s (Int64.to_int_exn i)))) 434 | ;; 435 | 436 | let caml_string_set = 437 | C3 438 | (fun st s i b -> 439 | let i = int_val i in 440 | if Int64.compare i 0L < 0 || Int64.compare i (string_length st s) >= 0 441 | then caml_array_bound_error st 442 | else ( 443 | set_byte' st s (Int64.to_int_exn i) b; 444 | Ok val_unit)) 445 | ;; 446 | 447 | let caml_ml_input = 448 | C4 449 | (fun st ic s ofs len -> 450 | let ofs = Int64.to_int_exn (int_val ofs) in 451 | let len = Int64.to_int_exn (int_val len) in 452 | let b = Bytes.create len in 453 | let ichan = find_chan_in st ic in 454 | let len = input ichan b 0 len in 455 | for i = 0 to len - 1 do 456 | set_byte st s (ofs + i) (Bytes.get b i) 457 | done; 458 | Ok (val_int (Int64.of_int len))) 459 | ;; 460 | 461 | let caml_ml_input_char = 462 | C1 463 | (fun st ic -> 464 | let chan = find_chan_in st ic in 465 | let ch = Char.to_int (input_char chan) in 466 | Ok (val_int (Int64.of_int ch))) 467 | ;; 468 | 469 | let caml_ml_input_int = 470 | C1 471 | (fun st ic -> 472 | let chan = find_chan_in st ic in 473 | let i = input_binary_int chan in 474 | Ok (val_int (Int64.of_int i))) 475 | ;; 476 | 477 | let caml_input_value = 478 | (*let cnt = ref 0 in*) 479 | C1 480 | (fun st ic -> 481 | let chan = find_chan_in st ic in 482 | let p = alloc_block_from st (input_value chan) in 483 | (*let f = open_out ("value.txt" ^ string_of_int !cnt) in 484 | let () = Trace.root f st.memory p in 485 | let () = close_out f; incr cnt in*) 486 | Ok p) 487 | ;; 488 | 489 | let caml_ml_channel_size = 490 | C1 491 | (fun st chan -> 492 | let x i = Ok (val_int (Int64.of_int i)) in 493 | try x (in_channel_length (find_chan_in st chan)) with 494 | | _ -> 495 | (try x (out_channel_length (find_chan_out st chan)) with 496 | | _ -> caml_raise_sys_error' st "caml_ml_channel_size")) 497 | ;; 498 | 499 | (* XXX has this been removed from the runtime? *) 500 | (* external is_printable : char -> bool = "caml_is_printable" 501 | * 502 | * let caml_is_printable = 503 | * C1 504 | * (fun _ c -> 505 | * Ok 506 | * ( if is_printable (Char.chr (to_int (int_val c))) then val_true 507 | * else val_false )) *) 508 | 509 | let caml_is_printable = 510 | C1 511 | (fun _ c -> 512 | Ok 513 | (if Char.is_print (Char.of_int_exn (Int64.to_int_exn (int_val c))) 514 | then val_true 515 | else val_false)) 516 | ;; 517 | 518 | let caml_sys_file_exists = 519 | C1 520 | (fun st name -> 521 | Ok (if Caml.Sys.file_exists (get_obj st name : string) then val_true else val_false)) 522 | ;; 523 | 524 | external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" 525 | 526 | let caml_sys_open = 527 | C3 528 | (fun st fname mode perm -> 529 | let fname = get_string st fname in 530 | let mode = (get_obj st mode : open_flag list) in 531 | let perm = Int64.to_int_exn (int_val perm) in 532 | (*Printf.printf "sys_open %s, mode=%i, perm=%x\n" 533 | fname (List.length mode) perm;*) 534 | let fd = open_desc fname mode perm in 535 | Ok (val_int (Int64.of_int fd))) 536 | ;; 537 | 538 | let caml_create_string = 539 | C1 540 | (fun st len -> 541 | let x = String.make (Int64.to_int_exn (int_val len)) (Char.of_int_exn 0) in 542 | Ok (alloc_block_from st x)) 543 | ;; 544 | 545 | let caml_blit_string = 546 | C5 547 | (fun st s1 ofs1 s2 ofs2 n -> 548 | let n = Int64.to_int_exn (int_val n) in 549 | let ofs1 = Int64.to_int_exn (int_val ofs1) in 550 | let ofs2 = Int64.to_int_exn (int_val ofs2) in 551 | for i = 0 to n - 1 do 552 | let b = Char.of_int_exn @@ Int64.to_int_exn @@ get_byte st s1 (ofs1 + i) in 553 | set_byte st s2 (ofs2 + i) b 554 | done; 555 | Ok val_unit) 556 | ;; 557 | 558 | let caml_fill_string = 559 | C4 560 | (fun st s ofs len v -> 561 | let ofs = Int64.to_int_exn (int_val ofs) in 562 | let len = Int64.to_int_exn (int_val len) in 563 | for i = 0 to len - 1 do 564 | set_byte st s (ofs + i) (Char.of_int_exn (Int64.to_int_exn (int_val v))) 565 | done; 566 | Ok val_unit) 567 | ;; 568 | 569 | let string_compare st s1 s2 = 570 | let s1 = (get_obj st s1 : string) in 571 | let s2 = (get_obj st s2 : string) in 572 | String.compare s1 s2 573 | ;; 574 | 575 | let caml_string_equal = 576 | C2 (fun st s1 s2 -> Ok (if string_compare st s1 s2 = 0 then val_true else val_false)) 577 | ;; 578 | 579 | let caml_string_notequal = 580 | C2 (fun st s1 s2 -> Ok (if string_compare st s1 s2 <> 0 then val_true else val_false)) 581 | ;; 582 | 583 | let caml_string_compare = 584 | C2 (fun st s1 s2 -> Ok (val_int (Int64.of_int (string_compare st s1 s2)))) 585 | ;; 586 | 587 | let argv = ref ("hardcamlzinc", [| "hardcamlzinc" |]) 588 | let caml_sys_get_argv = C1 (fun st _ -> Ok (alloc_block_from st !argv)) 589 | let caml_sys_get_config = C1 (fun st _ -> Ok (alloc_block_from st ("Unix", 64, false))) 590 | 591 | let caml_sys_getenv = 592 | C1 593 | (fun st v -> 594 | let v = get_string st v in 595 | match Sys.getenv v with 596 | | Some e -> Ok (alloc_block_from st e) 597 | | None -> caml_raise_not_found st) 598 | ;; 599 | 600 | let caml_make_vect = 601 | C2 602 | (fun st len init -> 603 | let len = int_val len in 604 | if Int64.equal len 0L 605 | then Ok st.atom_table 606 | else ( 607 | let tag = 608 | if Int64.equal (is_block init) 1L 609 | && Int64.equal (tag (header st init)) double_tag 610 | then double_array_tag 611 | else 0L 612 | in 613 | let p = alloc_block ~st ~size:len ~tag ~colour:white in 614 | for i = 0 to Int64.to_int_exn len - 1 do 615 | set_field st p i init 616 | done; 617 | Ok p)) 618 | ;; 619 | 620 | let caml_array_get_addr st a idx = 621 | let idx = int_val idx in 622 | let size = size (header st a) in 623 | if Int64.compare idx size >= 0 || Int64.compare idx 0L < 0 624 | then caml_array_bound_error st 625 | else Ok (field st a (Int64.to_int_exn idx)) 626 | ;; 627 | 628 | let caml_array_get_float st a idx = 629 | let idx = int_val idx in 630 | let size = size (header st a) in 631 | if Int64.compare idx size >= 0 || Int64.compare idx 0L < 0 632 | then caml_array_bound_error st 633 | else ( 634 | let p = alloc_block ~st ~size:1L ~colour:white ~tag:double_tag in 635 | set_field st p 0 (field st a (Int64.to_int_exn idx)); 636 | Ok p) 637 | ;; 638 | 639 | let caml_array_get = 640 | C2 641 | (fun st a idx -> 642 | if Int64.equal (tag (header st a)) double_array_tag 643 | then caml_array_get_float st a idx 644 | else caml_array_get_addr st a idx) 645 | ;; 646 | 647 | let caml_array_set_addr st a idx v = 648 | let idx = int_val idx in 649 | let size = size (header st a) in 650 | if Int64.compare idx size >= 0 || Int64.compare idx 0L < 0 651 | then caml_array_bound_error st 652 | else ( 653 | modify st a (Int64.to_int_exn idx) v; 654 | Ok val_unit) 655 | ;; 656 | 657 | let caml_array_set_float st a idx v = 658 | let idx = int_val idx in 659 | let size = size (header st a) in 660 | if Int64.compare idx size >= 0 || Int64.compare idx 0L < 0 661 | then caml_array_bound_error st 662 | else ( 663 | set_field st a (Int64.to_int_exn idx) (field st v 0); 664 | Ok val_unit) 665 | ;; 666 | 667 | let caml_array_set = 668 | C3 669 | (fun st a idx v -> 670 | if Int64.equal (tag (header st a)) double_array_tag 671 | then caml_array_set_float st a idx v 672 | else caml_array_set_addr st a idx v) 673 | ;; 674 | 675 | let caml_array_sub = 676 | C3 677 | (fun st a ofs len -> 678 | let ofs = int_val ofs in 679 | let len = int_val len in 680 | let size = size (header st a) in 681 | if Int64.compare ofs 0L < 0 682 | || Int64.compare len 0L < 0 683 | || Int64.compare (ofs +: len) size > 0 684 | then caml_invalid_argument' st "Array.sub" 685 | else if Int64.equal len 0L 686 | then Ok st.atom_table 687 | else ( 688 | let p = alloc_block ~st ~size:len ~tag:0L ~colour:white in 689 | for i = 0 to Int64.to_int_exn len - 1 do 690 | set_field st p i (field st a (Int64.to_int_exn ofs + i)) 691 | done; 692 | Ok p)) 693 | ;; 694 | 695 | let caml_array_blit = 696 | C5 697 | (fun st src sofs dst dofs len -> 698 | let sofs = Int64.to_int_exn (int_val sofs) in 699 | let dofs = Int64.to_int_exn (int_val dofs) in 700 | let len = Int64.to_int_exn (int_val len) in 701 | if dofs < sofs 702 | then 703 | for i = 0 to len - 1 do 704 | set_field st dst (i + dofs) (field st src (i + sofs)) 705 | done 706 | else 707 | for i = len - 1 downto 0 do 708 | set_field st dst (i + dofs) (field st src (i + sofs)) 709 | done; 710 | Ok val_unit) 711 | ;; 712 | 713 | let caml_obj_block = 714 | C2 715 | (fun st tag size -> 716 | let size = int_val size in 717 | let tag = int_val tag in 718 | if Int64.equal size 0L 719 | then Ok (st.atom_table +: aofs tag) 720 | else ( 721 | let p = alloc_block ~st ~size ~tag ~colour:white in 722 | for i = 0 to Int64.to_int_exn size - 1 do 723 | set_field st p i (val_int 0L) 724 | done; 725 | Ok p)) 726 | ;; 727 | 728 | let caml_obj_dup = 729 | C1 730 | (fun st obj -> 731 | let size = size (header st obj) in 732 | if Int64.equal size 0L 733 | then Ok obj 734 | else ( 735 | let tag = tag (header st obj) in 736 | let p = alloc_block ~st ~size ~tag ~colour:white in 737 | for i = 0 to Int64.to_int_exn size - 1 do 738 | set_field st p i (field st obj i) 739 | done; 740 | Ok p)) 741 | ;; 742 | 743 | let caml_obj_tag = 744 | C1 745 | (fun st obj -> 746 | if Int64.equal (is_int obj) 1L 747 | then Ok (val_int 1000L) 748 | else if not (Int64.equal (obj &: 7L) 0L) 749 | then Ok (val_int 1002L) (* else if obj < st.heap then Ok (val_int 1001L) *) 750 | else Ok (val_int (tag (header st obj)))) 751 | ;; 752 | 753 | let caml_obj_set_tag = 754 | C2 755 | (fun st arg tag -> 756 | let hdr = header st arg in 757 | set_header st arg (hdr &: ~:255L |: int_val tag); 758 | Ok val_unit) 759 | ;; 760 | 761 | let caml_compare_val st a b = 762 | (* need better implementation *) 763 | let (a : Obj.t), (b : Obj.t) = get_obj st a, get_obj st b in 764 | Poly.compare a b 765 | ;; 766 | 767 | let caml_hash = 768 | C4 769 | (fun st _ _ _ a -> 770 | let (a : Obj.t) = get_obj st a in 771 | let x = Hashtbl.hash a in 772 | Ok (val_int (Int64.of_int x))) 773 | ;; 774 | 775 | (* capture and return possible exceptions *) 776 | let caml_compare st a b = Ok (val_int (Int64.of_int (caml_compare_val st a b))) 777 | 778 | let caml_equal st a b = 779 | Ok (val_int (Int64.of_int (if caml_compare_val st a b = 0 then 1 else 0))) 780 | ;; 781 | 782 | let caml_notequal st a b = 783 | Ok (val_int (Int64.of_int (if caml_compare_val st a b <> 0 then 1 else 0))) 784 | ;; 785 | 786 | let caml_lessthan st a b = 787 | Ok (val_int (Int64.of_int (if caml_compare_val st a b < 0 then 1 else 0))) 788 | ;; 789 | 790 | let caml_lessequal st a b = 791 | Ok (val_int (Int64.of_int (if caml_compare_val st a b <= 0 then 1 else 0))) 792 | ;; 793 | 794 | let caml_greaterthan st a b = 795 | Ok (val_int (Int64.of_int (if caml_compare_val st a b > 0 then 1 else 0))) 796 | ;; 797 | 798 | let caml_greaterequal st a b = 799 | Ok (val_int (Int64.of_int (if caml_compare_val st a b >= 0 then 1 else 0))) 800 | ;; 801 | 802 | let caml_weak_list_head = ref 0L 803 | let caml_weak_none = 0L (* XXX ??? *) 804 | 805 | let caml_weak_create = 806 | C1 807 | (fun st len -> 808 | let size = int_val len +: 1L in 809 | if Int64.compare size 0L <= 0 (*|| size > max_wosize*) 810 | then caml_invalid_argument' st "Weak.create" 811 | else ( 812 | let p = alloc_block ~st ~size ~colour:white ~tag:abstract_tag in 813 | set_field st p 0 !caml_weak_list_head; 814 | caml_weak_list_head := p; 815 | for i = 1 to Int64.to_int_exn size - 1 do 816 | set_field st p i caml_weak_none 817 | done; 818 | Ok p)) 819 | ;; 820 | 821 | let caml_dynlink_get_current_libs = C1 (fun st _ -> Ok st.atom_table) 822 | 823 | external format_int : string -> int -> string = "caml_format_int" 824 | 825 | let caml_format_int = 826 | C2 827 | (fun st fmt arg -> 828 | let s = format_int (get_obj st fmt : string) (get_obj st arg : int) in 829 | Ok (alloc_block_from st s)) 830 | ;; 831 | 832 | let update_fields : state -> int64 -> 'a -> unit = 833 | fun st p o -> 834 | let o = Obj.repr o in 835 | for i = 0 to Obj.size o - 1 do 836 | set_field st p i (Repr.int64_of_obj (Obj.field o i)) 837 | done 838 | ;; 839 | 840 | (* 841 | 842 | This is input to the c-call and some fields are updated. 843 | note; we cannot convert functions across the c-call boundary, but refill_buff 844 | is not used anyway. 845 | 846 | type lexbuf = 847 | { refill_buff : lexbuf -> unit; 0 not used 848 | mutable lex_buffer : bytes; 1 fields modified 849 | mutable lex_buffer_len : int; 2 read only 850 | mutable lex_abs_pos : int; 3 not used 851 | mutable lex_start_pos : int; 4 modified 852 | mutable lex_curr_pos : int; 5 modified 853 | mutable lex_last_pos : int; 6 modified 854 | mutable lex_last_action : int; 7 modified 855 | mutable lex_eof_reached : bool; 8 modified 856 | mutable lex_mem : int array; 9 fields modified 857 | mutable lex_start_p : position; 10 not used 858 | mutable lex_curr_p : position; 11 not used 859 | } 860 | *) 861 | external lex_c_engine 862 | : Lexing.lex_tables 863 | -> int 864 | -> Lexing.lexbuf 865 | -> int 866 | = "caml_lex_engine" 867 | 868 | external new_lex_c_engine 869 | : Lexing.lex_tables 870 | -> int 871 | -> Lexing.lexbuf 872 | -> int 873 | = "caml_new_lex_engine" 874 | 875 | let caml_lex_engine' lex_engine = 876 | C3 877 | (fun st tab start buf -> 878 | let tab' = (get_obj st tab : Lexing.lex_tables) in 879 | (* might be worth cacheing this? *) 880 | let start = Int64.to_int_exn (int_val start) in 881 | let buf' = (get_obj ~closure:false st buf : Lexing.lexbuf) in 882 | let res = lex_engine tab' start buf' in 883 | update_fields st (field st buf 1) buf'.Lexing.lex_buffer; 884 | set_field st buf 4 (val_int (Int64.of_int buf'.Lexing.lex_start_pos)); 885 | set_field st buf 5 (val_int (Int64.of_int buf'.Lexing.lex_curr_pos)); 886 | set_field st buf 6 (val_int (Int64.of_int buf'.Lexing.lex_last_pos)); 887 | set_field st buf 7 (val_int (Int64.of_int buf'.Lexing.lex_last_action)); 888 | set_field st buf 8 (if buf'.Lexing.lex_eof_reached then val_true else val_false); 889 | update_fields st (field st buf 9) buf'.Lexing.lex_mem; 890 | Ok (val_int (Int64.of_int res))) 891 | ;; 892 | 893 | let caml_lex_engine = caml_lex_engine' lex_c_engine 894 | let caml_new_lex_engine = caml_lex_engine' new_lex_c_engine 895 | 896 | type position = Lexing.position 897 | 898 | type parser_env = 899 | { mutable s_stack : int array 900 | ; (* 0 fields modified *) 901 | mutable v_stack : Obj.t array 902 | ; (* 1 fields modified *) 903 | mutable symb_start_stack : position array 904 | ; (* 2 fields modified *) 905 | mutable symb_end_stack : position array 906 | ; (* 3 fields modified *) 907 | mutable stacksize : int 908 | ; (* 4 read only *) 909 | mutable stackbase : int 910 | ; (* 5 read only *) 911 | mutable curr_char : int 912 | ; (* 6 modified *) 913 | mutable lval : Obj.t 914 | ; (* 7 modified - xxx *) 915 | mutable symb_start : position 916 | ; (* 8 read only *) 917 | mutable symb_end : position 918 | ; (* 9 read only *) 919 | mutable asp : int 920 | ; (* 10 modified *) 921 | mutable rule_len : int 922 | ; (* 11 modified *) 923 | mutable rule_number : int 924 | ; (* 12 modified *) 925 | mutable sp : int 926 | ; (* 13 modified *) 927 | mutable state : int 928 | ; (* 14 modified *) 929 | mutable errflag : int 930 | } 931 | 932 | (* 15 modified *) 933 | 934 | external parse_engine 935 | : Parsing.parse_tables 936 | -> parser_env 937 | -> int 938 | -> Obj.t 939 | -> int 940 | = "caml_parse_engine" 941 | 942 | let caml_parse_engine = 943 | C4 944 | (fun st tab env inp obj -> 945 | let tab' = (get_obj ~closure:false st tab : Parsing.parse_tables) in 946 | let env' = (get_obj st env : parser_env) in 947 | let inp' = (get_obj st inp : int) in 948 | let obj' = (get_obj st obj : Obj.t) in 949 | (* not modified *) 950 | let res = parse_engine tab' env' inp' obj' in 951 | update_fields st (field st env 0) env'.s_stack; 952 | update_fields st (field st env 1) env'.v_stack; 953 | update_fields st (field st env 2) env'.symb_start_stack; 954 | update_fields st (field st env 3) env'.symb_end_stack; 955 | set_field st env 6 (val_int (Int64.of_int env'.curr_char)); 956 | set_field st env 7 (alloc_block_from st env'.lval); 957 | (* I think this is code... *) 958 | set_field st env 10 (val_int (Int64.of_int env'.asp)); 959 | set_field st env 11 (val_int (Int64.of_int env'.rule_len)); 960 | set_field st env 12 (val_int (Int64.of_int env'.rule_number)); 961 | set_field st env 13 (val_int (Int64.of_int env'.sp)); 962 | set_field st env 14 (val_int (Int64.of_int env'.state)); 963 | set_field st env 15 (val_int (Int64.of_int env'.errflag)); 964 | Ok (val_int (Int64.of_int res))) 965 | ;; 966 | 967 | module type Int = sig 968 | type t 969 | 970 | val add : t -> t -> t 971 | val logand : t -> t -> t 972 | 973 | (* bits_of_float *) 974 | (* bswap *) 975 | (* compare *) 976 | val div : t -> t -> t 977 | 978 | (* float_of_bits *) 979 | (* format *) 980 | val rem : t -> t -> t (* mod? *) 981 | 982 | val mul : t -> t -> t 983 | val neg : t -> t 984 | 985 | (* of_float *) 986 | (* of_int *) 987 | (* of_int32 *) 988 | (* of_nativeint *) 989 | (* of_string *) 990 | val logor : t -> t -> t 991 | val shift_left : t -> int -> t 992 | val shift_right : t -> int -> t 993 | val shift_right_logical : t -> int -> t 994 | val sub : t -> t -> t 995 | 996 | (* to_float *) 997 | (* to_int *) 998 | (* to_int32 *) 999 | (* to_nativeint *) 1000 | val logxor : t -> t -> t 1001 | val name : string 1002 | val to_t : int64 -> t 1003 | end 1004 | 1005 | module Nativeint_c_ops = struct 1006 | include Caml.Nativeint 1007 | 1008 | let name = "nativeint" 1009 | let to_t = Int64.to_nativeint_exn 1010 | end 1011 | 1012 | module Int64_c_ops = struct 1013 | include Caml.Nativeint 1014 | 1015 | let name = "nativeint" 1016 | let to_t = Int64.to_nativeint_exn 1017 | end 1018 | 1019 | module Int32_c_ops = struct 1020 | include Caml.Nativeint 1021 | 1022 | let name = "nativeint" 1023 | let to_t = Int64.to_nativeint_exn 1024 | end 1025 | 1026 | module Int_c_calls (I : Int) = struct 1027 | let op2 f = 1028 | C2 1029 | (fun st a b -> 1030 | let p = alloc_block ~st ~size:2L ~tag:custom_tag ~colour:white in 1031 | let c = f (I.to_t a) (I.to_t b) in 1032 | set_field st p 0 0L; 1033 | (* XXX should point to custom allocation block... *) 1034 | set_field st p 1 (Repr.int64_of_obj Obj.(field (repr c) 1)); 1035 | Ok p) 1036 | ;; 1037 | 1038 | let op1 f = 1039 | C1 1040 | (fun st a -> 1041 | let p = alloc_block ~st ~size:2L ~tag:custom_tag ~colour:white in 1042 | let c = f (I.to_t a) in 1043 | set_field st p 0 0L; 1044 | (* XXX should point to custom allocation block... *) 1045 | set_field st p 1 (Repr.int64_of_obj Obj.(field (repr c) 1)); 1046 | Ok p) 1047 | ;; 1048 | 1049 | let sftop f = 1050 | C2 1051 | (fun st a b -> 1052 | let p = alloc_block ~st ~size:2L ~tag:custom_tag ~colour:white in 1053 | let c = f (I.to_t a) (Int64.to_int_exn (int_val b)) in 1054 | set_field st p 0 0L; 1055 | (* XXX should point to custom allocation block... *) 1056 | set_field st p 1 (Repr.int64_of_obj Obj.(field (repr c) 1)); 1057 | Ok p) 1058 | ;; 1059 | 1060 | let c_calls = 1061 | [ "caml_" ^ I.name ^ "_add", op2 I.add 1062 | ; "caml_" ^ I.name ^ "_and", op2 I.logand 1063 | ; "caml_" ^ I.name ^ "_div", op2 I.div 1064 | ; "caml_" ^ I.name ^ "_mod", op2 I.rem 1065 | ; "caml_" ^ I.name ^ "_mul", op2 I.mul 1066 | ; "caml_" ^ I.name ^ "_neg", op1 I.neg 1067 | ; "caml_" ^ I.name ^ "_or", op2 I.logor 1068 | ; "caml_" ^ I.name ^ "_shift_left", sftop I.shift_left 1069 | ; "caml_" ^ I.name ^ "_shift_right", sftop I.shift_right 1070 | ; "caml_" ^ I.name ^ "_shift_right_unsigned", sftop I.shift_right_logical 1071 | ; "caml_" ^ I.name ^ "_sub", op2 I.sub 1072 | ; "caml_" ^ I.name ^ "_xor", op2 I.logxor 1073 | ] 1074 | ;; 1075 | end 1076 | 1077 | module Nativeint_c_calls = Int_c_calls (Nativeint_c_ops) 1078 | module Int64_c_calls = Int_c_calls (Int64_c_ops) 1079 | module Int32_c_calls = Int_c_calls (Int32_c_ops) 1080 | 1081 | let c_calls = 1082 | [ "caml_alloc_dummy", caml_alloc_dummy 1083 | ; "caml_update_dummy", caml_update_dummy 1084 | ; "caml_register_named_value", c2_unit 1085 | ; "caml_set_oo_id", caml_set_oo_id 1086 | ; "caml_fresh_oo_id", caml_fresh_oo_id 1087 | ; "caml_get_section_table", caml_get_section_table 1088 | ; "caml_int64_float_of_bits", caml_int64_float_of_bits 1089 | ; "caml_ml_open_descriptor_in", caml_ml_open_descriptor_in 1090 | ; "caml_ml_open_descriptor_out", caml_ml_open_descriptor_out 1091 | ; "caml_ml_close_channel", caml_ml_close_channel 1092 | ; "caml_ml_output_char", caml_ml_output_char 1093 | ; "caml_ml_string_length", caml_ml_string_length 1094 | ; "caml_ml_output", caml_ml_output 1095 | ; "caml_ml_out_channels_list", caml_ml_out_channels_list 1096 | ; "caml_ml_flush", caml_ml_flush 1097 | ; "caml_ml_input_scan_line", caml_ml_input_scan_line 1098 | ; "caml_ml_input", caml_ml_input 1099 | ; "caml_ml_input_char", caml_ml_input_char 1100 | ; "caml_ml_input_int", caml_ml_input_int 1101 | ; "caml_input_value", caml_input_value 1102 | ; "caml_ml_channel_size", caml_ml_channel_size 1103 | ; "caml_is_printable", caml_is_printable 1104 | ; "caml_ml_seek_in", caml_ml_seek_in 1105 | ; "caml_ml_seek_out", caml_ml_seek_out 1106 | ; "caml_create_string", caml_create_string 1107 | ; "caml_blit_string", caml_blit_string 1108 | ; "caml_fill_string", caml_fill_string 1109 | ; "caml_string_equal", caml_string_equal 1110 | ; "caml_string_notequal", caml_string_notequal 1111 | ; "caml_string_compare", caml_string_compare 1112 | ; "caml_string_get", caml_string_get 1113 | ; "caml_string_set", caml_string_set 1114 | ; "caml_sys_open", caml_sys_open 1115 | ; "caml_sys_get_argv", caml_sys_get_argv 1116 | ; "caml_sys_get_config", caml_sys_get_config 1117 | ; "caml_sys_const_big_endian", c1_false 1118 | ; "caml_sys_const_word_size", c1_int 64L 1119 | ; "caml_sys_const_ostype_unix", c1_true 1120 | ; "caml_sys_const_ostype_win32", c1_false 1121 | ; "caml_sys_const_ostype_cygwin", c1_false 1122 | ; "caml_sys_getenv", caml_sys_getenv 1123 | ; "caml_sys_file_exists", caml_sys_file_exists 1124 | ; "caml_array_get_addr", C2 caml_array_get_addr 1125 | ; "caml_array_get_float", C2 caml_array_get_float 1126 | ; "caml_array_get", caml_array_get 1127 | ; "caml_array_set_addr", C3 caml_array_set_addr 1128 | ; "caml_array_set_float", C3 caml_array_set_float 1129 | ; "caml_array_set", caml_array_set 1130 | ; "caml_array_unsafe_get_addr", C2 caml_array_get_addr 1131 | ; "caml_array_unsafe_get_float", C2 caml_array_get_float 1132 | ; "caml_array_unsafe_get", caml_array_get 1133 | ; "caml_array_unsafe_set_addr", C3 caml_array_set_addr 1134 | ; "caml_array_unsafe_set_float", C3 caml_array_set_float 1135 | ; "caml_array_unsafe_set", caml_array_set 1136 | ; "caml_array_sub", caml_array_sub 1137 | ; "caml_array_blit", caml_array_blit 1138 | ; "caml_make_vect", caml_make_vect 1139 | ; "caml_obj_block", caml_obj_block 1140 | ; "caml_obj_dup", caml_obj_dup 1141 | ; "caml_obj_tag", caml_obj_tag 1142 | ; "caml_obj_set_tag", caml_obj_set_tag 1143 | ; "caml_compare", C2 caml_compare 1144 | ; "caml_equal", C2 caml_equal 1145 | ; "caml_notequal", C2 caml_notequal 1146 | ; "caml_lessthan", C2 caml_lessthan 1147 | ; "caml_lessequal", C2 caml_lessequal 1148 | ; "caml_greaterthan", C2 caml_greaterthan 1149 | ; "caml_greaterequal", C2 caml_greaterequal 1150 | ; "caml_int_compare", C2 caml_compare 1151 | ; "caml_hash", caml_hash 1152 | ; "caml_weak_create", caml_weak_create 1153 | ; "caml_ensure_stack_capacity", c1_unit 1154 | ; "caml_dynlink_get_current_libs", caml_dynlink_get_current_libs 1155 | ; "caml_format_int", caml_format_int 1156 | ; "caml_install_signal_handler", c2_int 0L 1157 | ; "caml_lex_engine", caml_lex_engine 1158 | ; "caml_new_lex_engine", caml_new_lex_engine 1159 | ; "caml_parse_engine", caml_parse_engine 1160 | ] 1161 | @ Nativeint_c_calls.c_calls 1162 | @ Int64_c_calls.c_calls 1163 | @ Int32_c_calls.c_calls 1164 | ;; 1165 | 1166 | let run bc prim st = 1167 | let arg ofs = st.memory.{(Int64.to_int_exn st.sp / 8) + ofs} in 1168 | match List.Assoc.find ~equal:String.equal c_calls bc.Load.prim.(prim) with 1169 | | Some (C1 f) -> f st st.accu 1170 | | Some (C2 f) -> f st st.accu (arg 1) 1171 | | Some (C3 f) -> f st st.accu (arg 1) (arg 2) 1172 | | Some (C4 f) -> f st st.accu (arg 1) (arg 2) (arg 3) 1173 | | Some (C5 f) -> f st st.accu (arg 1) (arg 2) (arg 3) (arg 4) 1174 | | Some CN -> failwith "C_CALLN not yet implemented" 1175 | | None -> failwith ("C primitive " ^ bc.Load.prim.(prim) ^ " not found") 1176 | ;; 1177 | -------------------------------------------------------------------------------- /src/c_runtime.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | open Machine 3 | 4 | type result = (Int64.t, Int64.t) Result.t 5 | 6 | type c_call = 7 | | C1 of (state -> Int64.t -> result) 8 | | C2 of (state -> Int64.t -> Int64.t -> result) 9 | | C3 of (state -> Int64.t -> Int64.t -> Int64.t -> result) 10 | | C4 of (state -> Int64.t -> Int64.t -> Int64.t -> Int64.t -> result) 11 | | C5 of (state -> Int64.t -> Int64.t -> Int64.t -> Int64.t -> Int64.t -> result) 12 | | CN 13 | 14 | exception Get_repr 15 | exception Get_obj 16 | exception Alloc_block_from 17 | 18 | val get_repr : ?closure:bool -> 'a -> int -> Int64.t array 19 | val get_obj : ?closure:bool -> state -> Int64.t -> 'a 20 | val alloc_block : st:state -> size:Int64.t -> colour:Int64.t -> tag:Int64.t -> Int64.t 21 | val alloc_block_from : state -> 'a -> Int64.t 22 | val init : int -> int -> unit 23 | val argv : (string * string array) ref 24 | val run : Load.bytecode_exe -> int -> state -> result 25 | -------------------------------------------------------------------------------- /src/compile_hardware.ml: -------------------------------------------------------------------------------- 1 | (* compile hardware design from [Interp] *) 2 | 3 | open Base 4 | open Interp 5 | 6 | (* Because we are building a 64 bit interpreter. We should look at a 32 bit one 7 | as well. *) 8 | let dbits = 64 9 | 10 | module Expression = struct 11 | let is_const = function 12 | | Const _ -> true 13 | | _ -> false 14 | ;; 15 | 16 | let const_value = function 17 | | Const n -> n 18 | | _ -> raise_s [%message "expr is not a constant"] 19 | ;; 20 | 21 | let const_equals e n = 22 | match e with 23 | | Const m when n = m -> true 24 | | _ -> false 25 | ;; 26 | 27 | let rec deps e = 28 | match e with 29 | | Op (_, e0, e1) -> deps e0 @ deps e1 30 | | Val id -> [ id ] 31 | | Const _ -> [] 32 | ;; 33 | 34 | let eval op e0 e1 = 35 | if is_const e0 && is_const e1 36 | then ( 37 | let e0, e1 = const_value e0, const_value e1 in 38 | match op with 39 | | "+" -> Some (Const (e0 + e1)) 40 | | "-" -> Some (Const (e0 - e1)) 41 | | "*" -> Some (Const (e0 * e1)) 42 | | "/" -> Some (Const (e0 / e1)) 43 | | "%" -> Some (Const (e0 % e1)) 44 | | "&" -> Some (Const (e0 land e1)) 45 | | "|" -> Some (Const (e0 lor e1)) 46 | | "^" -> Some (Const (e0 lxor e1)) 47 | | "~" -> Some (Const (lnot e0)) 48 | | "<<" -> Some (Const (e0 lsl e1)) 49 | | ">>" -> Some (Const (e0 lsr e1)) 50 | | ">>+" -> Some (Const (e0 asr e1)) 51 | | "==" -> Some (Const (if e0 = e1 then 1 else 0)) 52 | | "<>" -> Some (Const (if e0 <> e1 then 1 else 0)) 53 | | _ -> None) 54 | else None 55 | ;; 56 | 57 | let rec simplify e = 58 | match e with 59 | | Op (op, e0, e1) -> 60 | let e0, e1 = simplify e0, simplify e1 in 61 | (match eval op e0 e1 with 62 | | Some e -> e 63 | | None -> 64 | (match op with 65 | | "+" when const_equals e0 0 -> e1 (* a + 0 = a *) 66 | | "+" when const_equals e1 0 -> e0 (* 0 + a = a *) 67 | | "-" when const_equals e1 0 -> e0 (* a - 0 = a *) 68 | | "*" when const_equals e1 1 -> e0 (* a * 1 = a *) 69 | | "*" when const_equals e0 1 -> e1 (* 1 * a = a *) 70 | | "/" when const_equals e1 1 -> e0 (* a / 1 = a *) 71 | | "<<" when const_equals e1 0 -> e1 (* a lsl 0 = a *) 72 | | ">>" when const_equals e1 0 -> e1 (* a lsr 0 = a *) 73 | | ">>+" when const_equals e1 0 -> e1 (* a asr 0 = a *) 74 | | _ -> Op (op, e0, e1))) 75 | | Const _ -> e 76 | | Val _ -> e 77 | ;; 78 | 79 | module S = Hardcaml.Signal 80 | 81 | let rec compile lookup = function 82 | | Interp.Op (op, a', b') -> 83 | let a, b = 84 | try compile lookup a', compile lookup b' with 85 | | e -> raise_s [%message "failed to look up subexpression" (e : exn)] 86 | in 87 | (match op with 88 | | "+" -> S.( +: ) a b 89 | | "-" -> S.( -: ) a b 90 | | "|" -> S.( |: ) a b 91 | | "&" -> S.( &: ) a b 92 | | "^" -> S.( ^: ) a b 93 | | ">+" -> S.( >+ ) a b 94 | | ">>" -> S.srl a (const_value b') 95 | | ">>+" -> S.sra a (const_value b') 96 | | "<<" -> S.sll a (const_value b') 97 | | _ -> raise_s [%message "unknown expression operator" (op : string)]) 98 | | Val id -> lookup id 99 | | Const x -> S.consti ~width:dbits x 100 | ;; 101 | end 102 | 103 | module Statement = struct 104 | let rec deps x = 105 | match x with 106 | | Get_reg (_, _) -> `cmd (x, []) 107 | | Set_reg (_, value) -> `cmd (x, Expression.deps value) 108 | | Get_mem (_, _, addr) -> `cmd (x, Expression.deps addr) 109 | | Set_mem (_, addr, value) -> `cmd (x, Expression.deps addr @ Expression.deps value) 110 | | Cond (c, t, f) -> 111 | `cond (x, Expression.deps c, List.map t ~f:deps, List.map f ~f:deps) 112 | | Iter (_, _, f, t, c) -> 113 | `iter (x, Expression.deps f @ Expression.deps t, List.map c ~f:deps) 114 | ;; 115 | 116 | (* XXX I am not sure if this is either needed or useful in it's current form.*) 117 | let _ = deps 118 | 119 | let rec simplify_stat = function 120 | | Get_reg (id, reg) -> Get_reg (id, reg) 121 | | Set_reg (reg, value) -> Set_reg (reg, Expression.simplify value) 122 | | Get_mem (id, cache, addr) -> Get_mem (id, cache, Expression.simplify addr) 123 | | Set_mem (cache, addr, value) -> 124 | Set_mem (cache, Expression.simplify addr, Expression.simplify value) 125 | | Cond (c, t, f) -> Cond (Expression.simplify c, simplify_stats t, simplify_stats f) 126 | | Iter (ud, id, f, t, c) -> 127 | Iter (ud, id, Expression.simplify f, Expression.simplify t, simplify_stats c) 128 | 129 | and simplify_stats x = List.map x ~f:simplify_stat 130 | 131 | let simplify st = { st with cmd = simplify_stats st.cmd } 132 | 133 | module Usage = struct 134 | type t = 135 | { read_registers : Machine.Register.t list 136 | ; write_registers : Machine.Register.t list 137 | ; read_memories : Machine.Cache.t list 138 | ; write_memories : Machine.Cache.t list 139 | } 140 | 141 | let z = 142 | { read_registers = [] 143 | ; write_registers = [] 144 | ; read_memories = [] 145 | ; write_memories = [] 146 | } 147 | ;; 148 | 149 | let merge a b = 150 | { read_registers = a.read_registers @ b.read_registers 151 | ; write_registers = a.write_registers @ b.write_registers 152 | ; read_memories = a.read_memories @ b.read_memories 153 | ; write_memories = a.write_memories @ b.write_memories 154 | } 155 | ;; 156 | 157 | let rec usage1 st = 158 | match st with 159 | | Get_reg (_, reg) -> { z with read_registers = [ reg ] } 160 | | Set_reg (reg, _) -> { z with write_registers = [ reg ] } 161 | | Get_mem (_, mem, _) -> { z with read_memories = [ mem ] } 162 | | Set_mem (mem, _, _) -> { z with write_memories = [ mem ] } 163 | | Cond (_, t, f) -> merge (usage t) (usage f) 164 | | Iter (_, _, _, _, body) -> usage body 165 | 166 | and usage st_list = List.fold st_list ~init:z ~f:(fun acc st -> merge acc (usage1 st)) 167 | 168 | let create st = 169 | let a = usage st in 170 | { read_registers = 171 | Set.of_list (module Machine.Register) a.read_registers |> Set.to_list 172 | ; write_registers = 173 | Set.of_list (module Machine.Register) a.write_registers |> Set.to_list 174 | ; read_memories = Set.of_list (module Machine.Cache) a.read_memories |> Set.to_list 175 | ; write_memories = 176 | Set.of_list (module Machine.Cache) a.write_memories |> Set.to_list 177 | } 178 | ;; 179 | end 180 | end 181 | 182 | (* Before we try to optimise anything, lets due a purely sequential statemachine. 183 | 184 | I need to work out how to manage the statemachine representation. 185 | *) 186 | module Sequential = struct 187 | open Hardcaml 188 | open Signal 189 | 190 | module Zinc_register = struct 191 | (* A bit of internal plumbing so the registers can be exposed as an interface *) 192 | type 'a t = 'a array [@@deriving sexp_of] 193 | 194 | module Pre : Hardcaml.Interface.Pre with type 'a t = 'a t = struct 195 | type nonrec 'a t = 'a t [@@deriving sexp_of] 196 | 197 | let map = Array.map 198 | let map2 a b ~f = Array.init (Array.length a) ~f:(fun i -> f a.(i) b.(i)) 199 | let iter = Array.iter 200 | let iter2 a b ~f = ignore (map2 a b ~f : unit array) 201 | let to_list = Array.to_list 202 | 203 | let t = 204 | Machine.Register.all 205 | |> List.map ~f:(fun x -> Sexp.to_string_hum (Machine.Register.sexp_of_t x), dbits) 206 | |> Array.of_list 207 | ;; 208 | end 209 | 210 | include Interface.Make (Pre) 211 | 212 | let create reg_spec = 213 | List.map Machine.Register.all ~f:(fun _ -> 214 | Always.Variable.reg reg_spec ~enable:vdd ~width:64) 215 | |> Array.of_list 216 | ;; 217 | 218 | let var t register = t.(Machine.Register.Variants.to_rank register) 219 | let get t register = (var t register).Always.Variable.value 220 | end 221 | 222 | module Command_register = struct 223 | type t = 224 | { reg_spec : Reg_spec.t 225 | ; table : (int, Always.Variable.t) Hashtbl.t 226 | } 227 | 228 | let create reg_spec = { reg_spec; table = Hashtbl.create (module Int) } 229 | 230 | let var t index = 231 | match Hashtbl.find t.table index with 232 | | None -> 233 | let x = Always.Variable.reg t.reg_spec ~enable:vdd ~width:64 in 234 | ignore (x.value -- ("cmd_reg" ^ Int.to_string index) : Signal.t); 235 | Hashtbl.set t.table ~key:index ~data:x; 236 | x 237 | | Some x -> x 238 | ;; 239 | 240 | let lookup t index = 241 | match Hashtbl.find t.table index with 242 | | None -> raise_s [%message "Failed to lookup variable" (index : int)] 243 | | Some x -> x.value 244 | ;; 245 | end 246 | 247 | module Memory_control = struct 248 | let var_wire (n, b) = 249 | let v = Always.Variable.wire ~default:(zero b) in 250 | ignore (v.value -- n : Signal.t); 251 | v 252 | ;; 253 | 254 | module I = struct 255 | type 'a t = 256 | { read_available : 'a 257 | ; read_data : 'a [@bits dbits] 258 | ; write_complete : 'a 259 | } 260 | [@@deriving sexp_of, hardcaml] 261 | end 262 | 263 | module O = struct 264 | type 'a t = 265 | { read : 'a 266 | ; read_address : 'a [@bits dbits] 267 | ; write : 'a 268 | ; write_data : 'a [@bits dbits] 269 | ; write_address : 'a [@bits dbits] 270 | } 271 | [@@deriving sexp_of, hardcaml] 272 | 273 | let var_wires () = map t ~f:var_wire 274 | end 275 | end 276 | 277 | module I = struct 278 | type 'a t = 279 | { clock : 'a 280 | ; clear : 'a 281 | ; memory_in : 'a Memory_control.I.t [@rtlprefix "mi_"] 282 | ; program_in : 'a Memory_control.I.t [@rtlprefix "pi_"] 283 | ; stack_in : 'a Memory_control.I.t [@rtlprefix "si_"] 284 | } 285 | [@@deriving sexp_of, hardcaml] 286 | end 287 | 288 | module O = struct 289 | type 'a t = 290 | { memory_out : 'a Memory_control.O.t [@rtlprefix "mo_"] 291 | ; program_out : 'a Memory_control.O.t [@rtlprefix "po_"] 292 | ; stack_out : 'a Memory_control.O.t [@rtlprefix "so_"] 293 | ; zinc_registers : 'a Zinc_register.t 294 | } 295 | [@@deriving sexp_of, hardcaml] 296 | end 297 | 298 | let rec count_cmd_states : Interp.sp_cmd -> int = function 299 | | Get_reg _ -> 1 300 | | Set_reg _ -> 1 301 | | Get_mem _ -> 1 302 | | Set_mem _ -> 1 303 | | Cond (_, t, f) -> count_states t + count_states f + 1 304 | | Iter (_, _, _, _, body) -> count_states body + 2 305 | 306 | and count_states cmds = 307 | List.fold cmds ~init:1 ~f:(fun acc cmd -> acc + count_cmd_states cmd) 308 | ;; 309 | 310 | let compile st (i : _ I.t) = 311 | let reg_spec = Reg_spec.create () ~clock:i.clock ~clear:i.clear in 312 | let cmd = State_poly.normalise (Statement.simplify st).cmd in 313 | let stack_out = Memory_control.O.var_wires () in 314 | let program_out = Memory_control.O.var_wires () in 315 | let memory_out = Memory_control.O.var_wires () in 316 | let select_memory = function 317 | | Machine.Cache.Stack -> i.stack_in, stack_out 318 | | Program -> i.program_in, program_out 319 | | Mem -> i.memory_in, memory_out 320 | in 321 | let command_registers = Command_register.create reg_spec in 322 | let zinc_registers = Zinc_register.create reg_spec in 323 | (* XXX I figure we will probaby need to pre-process the computation to work 324 | out the number of states we need. Either way, it's not this once we 325 | support Cond and Iter. *) 326 | let num_states = count_states cmd in 327 | let module States = struct 328 | type t = int [@@deriving sexp_of, compare] 329 | 330 | let all = List.range 0 num_states 331 | end 332 | in 333 | let sm = Always.State_machine.create (module States) reg_spec ~enable:vdd in 334 | ignore (sm.current -- "state" : Signal.t); 335 | let rec compile state_number cmd = 336 | match cmd with 337 | | Get_reg (id, zinc_register) -> 338 | ( [ ( state_number 339 | , Always. 340 | [ Command_register.var command_registers id 341 | <-- Zinc_register.get zinc_registers zinc_register 342 | ; sm.set_next (state_number + 1) 343 | ] ) 344 | ] 345 | , state_number + 1 ) 346 | | Set_reg (zinc_register, expr) -> 347 | ( [ ( state_number 348 | , Always. 349 | [ Zinc_register.var zinc_registers zinc_register 350 | <-- Expression.compile (Command_register.lookup command_registers) expr 351 | ; sm.set_next (state_number + 1) 352 | ] ) 353 | ] 354 | , state_number + 1 ) 355 | | Get_mem (id, which_memory, address) -> 356 | let memory_in, memory_out = select_memory which_memory in 357 | ( [ ( state_number 358 | , Always. 359 | [ memory_out.read <-- vdd 360 | ; memory_out.read_address 361 | <-- Expression.compile 362 | (Command_register.lookup command_registers) 363 | address 364 | ; when_ 365 | memory_in.read_available 366 | [ Command_register.var command_registers id <-- memory_in.read_data 367 | ; sm.set_next (state_number + 1) 368 | ] 369 | ] ) 370 | ] 371 | , state_number + 1 ) 372 | | Set_mem (which_memory, address, data) -> 373 | let memory_in, memory_out = select_memory which_memory in 374 | ( [ ( state_number 375 | , Always. 376 | [ memory_out.write <-- vdd 377 | ; memory_out.write_address 378 | <-- Expression.compile 379 | (Command_register.lookup command_registers) 380 | address 381 | ; memory_out.write_data 382 | <-- Expression.compile (Command_register.lookup command_registers) data 383 | ; when_ memory_in.write_complete [ sm.set_next (state_number + 1) ] 384 | ] ) 385 | ] 386 | , state_number + 1 ) 387 | | Cond (c, t, f) -> 388 | let c = Expression.compile (Command_register.lookup command_registers) c in 389 | let t, t_state_number = compile_states (state_number + 1) [] t in 390 | let f, f_state_number = compile_states (t_state_number + 1) [] f in 391 | ( List.concat 392 | Always. 393 | [ [ ( state_number 394 | , [ if_ 395 | c 396 | [ sm.set_next (state_number + 1) ] 397 | [ sm.set_next (t_state_number + 1) ] 398 | ] ) 399 | ] 400 | ; t 401 | ; [ t_state_number, [ sm.set_next (f_state_number + 1) ] ] 402 | ; f 403 | ; [ f_state_number, [ sm.set_next (f_state_number + 1) ] ] 404 | ] 405 | , f_state_number + 1 ) 406 | | Iter (up_down, index_id, index_from, index_to, body) -> 407 | let index_from = 408 | Expression.compile (Command_register.lookup command_registers) index_from 409 | in 410 | let index_to = 411 | Expression.compile (Command_register.lookup command_registers) index_to 412 | in 413 | let looping = 414 | if up_down then index_from <: index_to else index_from >=: index_to 415 | in 416 | let index = Command_register.var command_registers index_id in 417 | let body, last_body_state_number = compile_states (state_number + 1) [] body in 418 | ( List.concat 419 | Always. 420 | [ [ ( state_number 421 | , [ index <-- index_from 422 | ; if_ 423 | looping 424 | [ sm.set_next (state_number + 1) ] 425 | [ sm.set_next (last_body_state_number + 2) ] 426 | ] ) 427 | ] 428 | ; body 429 | ; [ ( last_body_state_number 430 | , [ index <-- index.value +:. 1 431 | ; sm.set_next (last_body_state_number + 1) 432 | ] ) 433 | ; ( last_body_state_number + 1 434 | , [ if_ 435 | looping 436 | [ sm.set_next (state_number + 1) ] 437 | [ sm.set_next (last_body_state_number + 2) ] 438 | ] ) 439 | ] 440 | ] 441 | , last_body_state_number + 2 ) 442 | and compile_states current_state_number states cmd = 443 | match cmd with 444 | | [] -> states, current_state_number 445 | | h :: t -> 446 | let always, next_state_number = compile current_state_number h in 447 | compile_states next_state_number (states @ always) t 448 | in 449 | let states, _ = compile_states 0 [] cmd in 450 | try 451 | Always.( 452 | compile 453 | [ proc Zinc_register.(map zinc_registers ~f:(fun r -> r <-- r.value) |> to_list) 454 | ; proc 455 | Memory_control.O.( 456 | map memory_out ~f:(fun r -> r <-- zero (width r.value)) |> to_list) 457 | ; proc 458 | Memory_control.O.( 459 | map stack_out ~f:(fun r -> r <-- zero (width r.value)) |> to_list) 460 | ; proc 461 | Memory_control.O.( 462 | map program_out ~f:(fun r -> r <-- zero (width r.value)) |> to_list) 463 | ; sm.switch (states @ [ num_states - 1, [] ]) 464 | ]); 465 | { O.memory_out; program_out; stack_out; zinc_registers } 466 | |> O.map ~f:(fun o -> o.value) 467 | with 468 | | e -> 469 | raise_s 470 | [%message (num_states : int) (e : exn) (states : (int * Always.t list) list)] 471 | ;; 472 | end 473 | -------------------------------------------------------------------------------- /src/compile_hardware.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | open Hardcaml 3 | 4 | module Expression : sig 5 | val simplify : Interp.sp_t -> Interp.sp_t 6 | val compile : (int -> Signal.t) -> Interp.sp_t -> Hardcaml.Signal.t 7 | end 8 | 9 | module Statement : sig 10 | val simplify : Interp.sp_st -> Interp.sp_st 11 | 12 | module Usage : sig 13 | type t = 14 | { read_registers : Machine.Register.t list 15 | ; write_registers : Machine.Register.t list 16 | ; read_memories : Machine.Cache.t list 17 | ; write_memories : Machine.Cache.t list 18 | } 19 | 20 | val create : Interp.sp_cmd list -> t 21 | end 22 | end 23 | 24 | module Sequential : sig 25 | module Zinc_register : sig 26 | include Hardcaml.Interface.S 27 | 28 | val create : Reg_spec.t -> Always.Variable.t t 29 | val var : Always.Variable.t t -> Machine.Register.t -> Always.Variable.t 30 | val get : Always.Variable.t t -> Machine.Register.t -> Signal.t 31 | end 32 | 33 | module Command_register : sig 34 | type t 35 | 36 | val create : Reg_spec.t -> t 37 | val var : t -> int -> Always.Variable.t 38 | end 39 | 40 | module Memory_control : sig 41 | module I : sig 42 | type 'a t = 43 | { read_available : 'a 44 | ; read_data : 'a 45 | ; write_complete : 'a 46 | } 47 | [@@deriving sexp_of, hardcaml] 48 | end 49 | 50 | module O : sig 51 | type 'a t = 52 | { read : 'a 53 | ; read_address : 'a 54 | ; write : 'a 55 | ; write_data : 'a 56 | ; write_address : 'a 57 | } 58 | [@@deriving sexp_of, hardcaml] 59 | end 60 | end 61 | 62 | module I : sig 63 | type 'a t = 64 | { clock : 'a 65 | ; clear : 'a 66 | ; memory_in : 'a Memory_control.I.t 67 | ; program_in : 'a Memory_control.I.t 68 | ; stack_in : 'a Memory_control.I.t 69 | } 70 | [@@deriving sexp_of, hardcaml] 71 | end 72 | 73 | module O : sig 74 | type 'a t = 75 | { memory_out : 'a Memory_control.O.t 76 | ; program_out : 'a Memory_control.O.t 77 | ; stack_out : 'a Memory_control.O.t 78 | ; zinc_registers : 'a Zinc_register.t 79 | } 80 | [@@deriving sexp_of, hardcaml] 81 | end 82 | 83 | val compile : Interp.sp_st -> Signal.t Interface.Create_fn(I)(O).t 84 | end 85 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name hardcaml_zinc) 3 | (libraries hardcaml compiler-libs hardcaml_waveterm.interactive) 4 | (preprocess (pps ppx_jane ppx_deriving_hardcaml)) 5 | ) -------------------------------------------------------------------------------- /src/framework.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Machine 3 | 4 | let c_heap_size_bytes = 2 * 1024 * 1024 (* 2Mb c-heap *) 5 | 6 | let init_memory bc memory_size_words = 7 | let open Load in 8 | (* convert exe to 64 bit *) 9 | let code_size = (Array.length bc.code + 1) / 2 in 10 | let code_address = 0 in 11 | let exe i = 12 | let a, b = 13 | ( Int64.of_int32 bc.code.(i * 2) 14 | , try Int64.of_int32 bc.code.((i * 2) + 1) with 15 | | _ -> 0L ) 16 | in 17 | let a, b = Int64.(a land 0xFFFFFFFFL, b land 0xFFFFFFFFL) in 18 | Int64.(a lor shift_left b 32) 19 | in 20 | (* atoms table *) 21 | let atom i = Int64.of_int i in 22 | let atoms_address = code_size in 23 | (* globals *) 24 | let globals_address = atoms_address + 256 in 25 | let globals = get_global_data64 bc globals_address in 26 | (* init data *) 27 | let c_heap_address = globals_address + Array.length globals in 28 | let heap_address = c_heap_address + (c_heap_size_bytes / 8) in 29 | let memory = Bigarray.(Array1.create int64 c_layout memory_size_words) in 30 | let () = 31 | for i = 0 to memory_size_words - 1 do 32 | memory.{i} 33 | <- (if i < code_size 34 | then exe i 35 | else if i < globals_address 36 | then atom (i - code_size) 37 | else if i < c_heap_address 38 | then globals.(i - globals_address) 39 | else 0L) 40 | done 41 | in 42 | let stack_address = memory_size_words in 43 | (* init the c-heap *) 44 | let () = C_runtime.init (c_heap_address * 8) c_heap_size_bytes in 45 | ( { code_address = code_address * 8 46 | ; code_size = Array.length bc.code * 4 47 | ; atoms_address = atoms_address * 8 48 | ; globals_address = globals_address * 8 49 | ; c_heap_address = c_heap_address * 8 50 | ; c_heap_size = c_heap_size_bytes 51 | ; heap_address = heap_address * 8 52 | ; stack_address = stack_address * 8 53 | } 54 | , memory ) 55 | ;; 56 | 57 | let init_state mm memory bytecode = 58 | Machine. 59 | { pc = Int64.of_int mm.code_address 60 | ; sp = Int64.of_int mm.stack_address 61 | ; accu = 1L 62 | ; env = Int64.of_int (mm.atoms_address + 8) 63 | ; extra_args = 0L 64 | ; trapsp = Int64.of_int mm.stack_address 65 | ; global_data = Int64.of_int (mm.globals_address + 8) 66 | ; atom_table = Int64.of_int (mm.atoms_address + 8) 67 | ; alloc_base = Int64.of_int mm.heap_address 68 | ; stack_high = Int64.of_int mm.stack_address 69 | ; memory 70 | ; exe = bytecode 71 | ; mapping = mm 72 | } 73 | ;; 74 | 75 | module Interp = struct 76 | open Machine 77 | module S = Interp.State_eval 78 | 79 | module M = 80 | Interp.Monad 81 | (struct 82 | let trace = false 83 | end) 84 | (S) 85 | 86 | module O = Interp.Opcodes (M) 87 | 88 | let init ~prog ~argv ~memsize_kb = 89 | let bytecode = Load.bytecode_exe prog in 90 | C_runtime.argv := prog, argv; 91 | let mapping, memory = init_memory bytecode (memsize_kb * (1024 / 8)) in 92 | let state = init_state mapping memory bytecode in 93 | state 94 | ;; 95 | 96 | let do_c_call st nargs prim = 97 | let open Ops.Int64 in 98 | assert (not (Int64.equal nargs 0L)); 99 | (* XXX C_CALLN TODO *) 100 | let prim = Int64.to_int_exn prim in 101 | let setup_for_c_call st = 102 | let st = { st with sp = st.sp -: 8L } in 103 | st.memory.{Int64.to_int_exn st.sp / 8} <- st.env; 104 | st 105 | in 106 | let restore_after_c_call st v = 107 | { st with 108 | env = st.memory.{Int64.to_int_exn st.sp / 8} 109 | ; sp = st.sp +: (nargs *: 8L) 110 | ; accu = v 111 | } 112 | in 113 | let do_exception st v = 114 | let _, st = M.step { st with accu = v } O.(dispatch RAISE) in 115 | Some st 116 | in 117 | let st = setup_for_c_call st in 118 | match C_runtime.run st.exe prim st with 119 | | Ok v -> Some (restore_after_c_call st v) 120 | | Error v -> do_exception st v 121 | ;; 122 | 123 | let get_instr memory pc = 124 | let instr = memory.{pc / 2} in 125 | S.(sra (if pc % 2 = 0 then sll instr 32L else instr) 32L) 126 | ;; 127 | 128 | let step ?(trace = 0) st = 129 | (* fetch instruction *) 130 | let pc = Int64.to_int_exn st.pc / 4 in 131 | let instr = get_instr st.memory pc in 132 | let instr = Opcode.of_int @@ Int64.to_int_exn instr in 133 | let () = 134 | if trace > 0 then Trace.instr st; 135 | if trace > 1 then Trace.machine st 136 | in 137 | (* execute instruction *) 138 | let st = { st with pc = S.(st.pc +: 4L) } in 139 | let result, st = M.step st O.(dispatch instr) in 140 | match result with 141 | | `step -> Some st 142 | | `stop -> None 143 | | `c_call (nargs, prim) -> do_c_call st nargs prim 144 | ;; 145 | 146 | let interactive ~prog ~argv ~memsize_kb = 147 | let state = ref (init ~prog ~argv ~memsize_kb) in 148 | let running = ref true in 149 | let ninstrs = ref 0 in 150 | object (this) 151 | method step = 152 | if !running 153 | then ( 154 | Int.incr ninstrs; 155 | match step !state with 156 | | Some st -> state := st 157 | | None -> running := false) 158 | 159 | method steps n = 160 | let rec f m = 161 | if n <= 0 || m >= n 162 | then () 163 | else ( 164 | this#step; 165 | f (m + 1)) 166 | in 167 | f 0 168 | 169 | method stepto n = this#steps (n - this#ninstrs) 170 | 171 | method stepd = 172 | this#trace#instr; 173 | this#trace#machine; 174 | this#step; 175 | this#ninstrs 176 | 177 | method stepsd n = 178 | if n > 0 179 | then ( 180 | this#steps (n - 1); 181 | this#trace#instr; 182 | this#trace#machine; 183 | this#step; 184 | this#ninstrs) 185 | else this#ninstrs 186 | 187 | method steptod n = 188 | if n > this#ninstrs 189 | then ( 190 | this#stepto (n - 1); 191 | this#trace#instr; 192 | this#trace#machine; 193 | this#step; 194 | this#ninstrs) 195 | else this#ninstrs 196 | 197 | method state = !state 198 | 199 | method running = !running 200 | 201 | method ninstrs = !ninstrs 202 | 203 | method trace = 204 | object 205 | method machine = Trace.machine !state 206 | 207 | method instr = Trace.instr !state 208 | 209 | method value v = 210 | Trace.value !state v; 211 | Stdio.printf "\n" 212 | 213 | method root v = Trace.root !state v 214 | end 215 | end 216 | ;; 217 | end 218 | -------------------------------------------------------------------------------- /src/framework.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | val init_memory : Load.bytecode_exe -> int -> Machine.memory_mapping * Memory.t 4 | val init_state : Machine.memory_mapping -> Memory.t -> Load.bytecode_exe -> Machine.state 5 | 6 | module Interp : sig 7 | open Machine 8 | 9 | val init : prog:string -> argv:string array -> memsize_kb:int -> state 10 | val do_c_call : state -> Int64.t -> int64 -> state option 11 | val step : ?trace:int -> state -> state option 12 | 13 | val interactive 14 | : prog:string 15 | -> argv:string array 16 | -> memsize_kb:int 17 | -> < step : unit 18 | ; steps : int -> unit 19 | ; stepto : int -> unit 20 | ; stepd : int 21 | ; stepsd : int -> int 22 | ; steptod : int -> int 23 | ; state : state 24 | ; running : bool 25 | ; ninstrs : int 26 | ; trace : 27 | < machine : unit 28 | ; instr : unit 29 | ; value : Int64.t -> unit 30 | ; root : Int64.t -> unit > > 31 | end 32 | -------------------------------------------------------------------------------- /src/instruction.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | (* simple coding API for the byte codes, which includes any arguments. 4 | * we'll do a simple translation into an exe so we can run test sequences 5 | * through the testbench *) 6 | 7 | type t = Opcode.t * int32 list [@@deriving sexp_of] 8 | 9 | open Opcode 10 | 11 | let acc0 = ACC0, [] 12 | let acc1 = ACC1, [] 13 | let acc2 = ACC2, [] 14 | let acc3 = ACC3, [] 15 | let acc4 = ACC4, [] 16 | let acc5 = ACC5, [] 17 | let acc6 = ACC6, [] 18 | let acc7 = ACC7, [] 19 | let acc n = ACC, [ n ] 20 | let push = PUSH, [] 21 | let pushacc0 = PUSHACC0, [] 22 | let pushacc1 = PUSHACC1, [] 23 | let pushacc2 = PUSHACC2, [] 24 | let pushacc3 = PUSHACC3, [] 25 | let pushacc4 = PUSHACC4, [] 26 | let pushacc5 = PUSHACC5, [] 27 | let pushacc6 = PUSHACC6, [] 28 | let pushacc7 = PUSHACC7, [] 29 | let pushacc n = PUSHACC, [ n ] 30 | let pop n = POP, [ n ] 31 | let assign n = ASSIGN, [ n ] 32 | let envacc1 = ENVACC1, [] 33 | let envacc2 = ENVACC1, [] 34 | let envacc3 = ENVACC1, [] 35 | let envacc4 = ENVACC1, [] 36 | let envacc n = ENVACC, [ n ] 37 | let pushenvacc1 = PUSHENVACC1, [] 38 | let pushenvacc2 = PUSHENVACC2, [] 39 | let pushenvacc3 = PUSHENVACC3, [] 40 | let pushenvacc4 = PUSHENVACC4, [] 41 | let pushenvacc n = PUSHENVACC, [ n ] 42 | let push_retaddr n = PUSH_RETADDR, [ n ] 43 | let apply n = APPLY, [ n ] 44 | let apply1 n = APPLY1, [ n ] 45 | let apply2 n = APPLY2, [ n ] 46 | let apply3 n = APPLY3, [ n ] 47 | let appterm m n = APPTERM, [ m; n ] 48 | let appterm1 n = APPTERM1, [ n ] 49 | let appterm2 n = APPTERM2, [ n ] 50 | let appterm3 n = APPTERM3, [ n ] 51 | let return n = RETURN, [ n ] 52 | let restart = RESTART, [] 53 | let grab n = GRAB, [ n ] 54 | let closure n_vars func = CLOSURE, [ n_vars; func ] 55 | 56 | let closurerec n_vars funcs = 57 | CLOSUREREC, n_vars :: Int32.of_int_exn (List.length funcs) :: funcs 58 | ;; 59 | 60 | let pushoffsetclosure n = PUSHOFFSETCLOSURE, [ n ] 61 | let offsetclosure n = OFFSETCLOSURE, [ n ] 62 | let pushoffsetclosurem2 = PUSHOFFSETCLOSUREM2, [] 63 | let offsetclosure0 = OFFSETCLOSURE0, [] 64 | let pushoffsetclosure0 = PUSHOFFSETCLOSURE0, [] 65 | let offsetclosure2 = OFFSETCLOSURE2, [] 66 | let pushgetglobal n = PUSHGETGLOBAL, [ n ] 67 | let getglobal n = GETGLOBAL, [ n ] 68 | let pushgetglobalfield m n = PUSHGETGLOBALFIELD, [ n; m ] 69 | let getglobalfield m n = GETGLOBALFIELD, [ n; m ] 70 | let setglobal n = SETGLOBAL, [ n ] 71 | let pushatom0 = PUSHATOM0, [] 72 | let atom0 = ATOM0, [] 73 | let pushatom n = PUSHATOM, [ n ] 74 | let atom n = ATOM, [ n ] 75 | let makeblock m n = MAKEBLOCK, [ m; n ] 76 | let makeblock1 n = MAKEBLOCK1, [ n ] 77 | let makeblock2 n = MAKEBLOCK2, [ n ] 78 | let makeblock3 n = MAKEBLOCK3, [ n ] 79 | let makefloatblock n = MAKEFLOATBLOCK, [ n ] 80 | let getfield0 = GETFIELD0, [] 81 | let getfield1 = GETFIELD1, [] 82 | let getfield2 = GETFIELD2, [] 83 | let getfield3 = GETFIELD3, [] 84 | let getfield n = GETFIELD, [ n ] 85 | let getfloatfield n = GETFLOATFIELD, [ n ] 86 | let setfield0 = SETFIELD0, [] 87 | let setfield1 = SETFIELD1, [] 88 | let setfield2 = SETFIELD2, [] 89 | let setfield3 = SETFIELD3, [] 90 | let setfield n = SETFIELD, [ n ] 91 | let setfloatfield n = SETFLOATFIELD, [ n ] 92 | let vectlength = VECTLENGTH, [] 93 | let getvectitem = GETVECTITEM, [] 94 | let setvectitem = SETVECTITEM, [] 95 | let getstringchar = GETSTRINGCHAR, [] 96 | let setstringchar = SETSTRINGCHAR, [] 97 | let branch n = BRANCH, [ n ] 98 | let branchif n = BRANCHIF, [ n ] 99 | let branchifnot n = BRANCHIFNOT, [ n ] 100 | let switch sizes indices = SWITCH, sizes :: indices (* XXX *) 101 | 102 | let boolnot = BOOLNOT, [] 103 | let pushtrap n = PUSHTRAP, [ n ] 104 | let poptrap = POPTRAP, [] 105 | let raise_notrace = RAISE_NOTRACE, [] 106 | let reraise = RERAISE, [] 107 | let raise_ = RAISE, [] 108 | let check_signals = CHECK_SIGNALS, [] 109 | let c_call1 n = C_CALL1, [ n ] 110 | let c_call2 n = C_CALL2, [ n ] 111 | let c_call3 n = C_CALL3, [ n ] 112 | let c_call4 n = C_CALL4, [ n ] 113 | let c_call5 n = C_CALL5, [ n ] 114 | let c_calln n_args m = C_CALLN, [ n_args; m ] 115 | let const0 = CONST0, [] 116 | let const1 = CONST1, [] 117 | let const2 = CONST2, [] 118 | let const3 = CONST3, [] 119 | let pushconst0 = PUSHCONST0, [] 120 | let pushconst1 = PUSHCONST1, [] 121 | let pushconst2 = PUSHCONST2, [] 122 | let pushconst3 = PUSHCONST3, [] 123 | let pushconstint n = PUSHCONSTINT, [ n ] 124 | let constint n = CONSTINT, [ n ] 125 | let negint = NEGINT, [] 126 | let addint = ADDINT, [] 127 | let subint = SUBINT, [] 128 | let mulint = MULINT, [] 129 | let divint = DIVINT, [] 130 | let modint = MODINT, [] 131 | let andint = ANDINT, [] 132 | let orint = ORINT, [] 133 | let xorint = XORINT, [] 134 | let lslint = LSLINT, [] 135 | let lsrint = LSRINT, [] 136 | let asrint = ASRINT, [] 137 | let eq = EQ, [] 138 | let neq = NEQ, [] 139 | let ltint = LTINT, [] 140 | let leint = LEINT, [] 141 | let gtint = GTINT, [] 142 | let geint = GEINT, [] 143 | let ultint = ULTINT, [] 144 | let ugeint = UGEINT, [] 145 | let beq = BEQ, [] 146 | let bneq = BNEQ, [] 147 | let bltint = BLTINT, [] 148 | let bleint = BLEINT, [] 149 | let bgtint = BGTINT, [] 150 | let bgeint = BGEINT, [] 151 | let bultint = BULTINT, [] 152 | let bugeint = BUGEINT, [] 153 | let offsetint n = OFFSETINT, [ n ] 154 | let offsetref n = OFFSETREF, [ n ] 155 | let isint = ISINT, [] 156 | let getmethod = GETMETHOD, [] 157 | let getpubmet n = GETPUBMET, [ n ] (* not sure - some weird cache things *) 158 | 159 | let getdynmet n = GETDYNMET, [ n ] 160 | let stop = STOP, [] 161 | let event = EVENT, [] 162 | let break = BREAK, [] 163 | 164 | let to_array codes = 165 | Array.of_list 166 | @@ List.concat 167 | @@ List.map codes ~f:(fun (o, a) -> (Int32.of_int_exn @@ Opcode.to_int o) :: a) 168 | ;; 169 | -------------------------------------------------------------------------------- /src/instruction.mli: -------------------------------------------------------------------------------- 1 | type t = Opcode.t * int32 list [@@deriving sexp_of] 2 | 3 | val acc0 : t 4 | val acc1 : t 5 | val acc2 : t 6 | val acc3 : t 7 | val acc4 : t 8 | val acc5 : t 9 | val acc6 : t 10 | val acc7 : t 11 | val acc : int32 -> t 12 | val push : t 13 | val pushacc0 : t 14 | val pushacc1 : t 15 | val pushacc2 : t 16 | val pushacc3 : t 17 | val pushacc4 : t 18 | val pushacc5 : t 19 | val pushacc6 : t 20 | val pushacc7 : t 21 | val pushacc : int32 -> t 22 | val pop : int32 -> t 23 | val assign : int32 -> t 24 | val envacc1 : t 25 | val envacc2 : t 26 | val envacc3 : t 27 | val envacc4 : t 28 | val envacc : int32 -> t 29 | val pushenvacc1 : t 30 | val pushenvacc2 : t 31 | val pushenvacc3 : t 32 | val pushenvacc4 : t 33 | val pushenvacc : int32 -> t 34 | val push_retaddr : int32 -> t 35 | val apply : int32 -> t 36 | val apply1 : int32 -> t 37 | val apply2 : int32 -> t 38 | val apply3 : int32 -> t 39 | val appterm : int32 -> int32 -> t 40 | val appterm1 : int32 -> t 41 | val appterm2 : int32 -> t 42 | val appterm3 : int32 -> t 43 | val return : int32 -> t 44 | val restart : t 45 | val grab : int32 -> t 46 | val closure : int32 -> int32 -> t 47 | val closurerec : int32 -> int32 list -> t 48 | val pushoffsetclosure : int32 -> t 49 | val offsetclosure : int32 -> t 50 | val pushoffsetclosurem2 : t 51 | val offsetclosure0 : t 52 | val pushoffsetclosure0 : t 53 | val offsetclosure2 : t 54 | val pushgetglobal : int32 -> t 55 | val getglobal : int32 -> t 56 | val pushgetglobalfield : int32 -> int32 -> t 57 | val getglobalfield : int32 -> int32 -> t 58 | val setglobal : int32 -> t 59 | val pushatom0 : t 60 | val atom0 : t 61 | val pushatom : int32 -> t 62 | val atom : int32 -> t 63 | val makeblock : int32 -> int32 -> t 64 | val makeblock1 : int32 -> t 65 | val makeblock2 : int32 -> t 66 | val makeblock3 : int32 -> t 67 | val makefloatblock : int32 -> t 68 | val getfield0 : t 69 | val getfield1 : t 70 | val getfield2 : t 71 | val getfield3 : t 72 | val getfield : int32 -> t 73 | val getfloatfield : int32 -> t 74 | val setfield0 : t 75 | val setfield1 : t 76 | val setfield2 : t 77 | val setfield3 : t 78 | val setfield : int32 -> t 79 | val setfloatfield : int32 -> t 80 | val vectlength : t 81 | val getvectitem : t 82 | val setvectitem : t 83 | val getstringchar : t 84 | val setstringchar : t 85 | val branch : int32 -> t 86 | val branchif : int32 -> t 87 | val branchifnot : int32 -> t 88 | val switch : int32 -> int32 list -> t 89 | val boolnot : t 90 | val pushtrap : int32 -> t 91 | val poptrap : t 92 | val raise_notrace : t 93 | val reraise : t 94 | val raise_ : t 95 | val check_signals : t 96 | val c_call1 : int32 -> t 97 | val c_call2 : int32 -> t 98 | val c_call3 : int32 -> t 99 | val c_call4 : int32 -> t 100 | val c_call5 : int32 -> t 101 | val c_calln : int32 -> int32 -> t 102 | val const0 : t 103 | val const1 : t 104 | val const2 : t 105 | val const3 : t 106 | val pushconst0 : t 107 | val pushconst1 : t 108 | val pushconst2 : t 109 | val pushconst3 : t 110 | val pushconstint : int32 -> t 111 | val constint : int32 -> t 112 | val negint : t 113 | val addint : t 114 | val subint : t 115 | val mulint : t 116 | val divint : t 117 | val modint : t 118 | val andint : t 119 | val orint : t 120 | val xorint : t 121 | val lslint : t 122 | val lsrint : t 123 | val asrint : t 124 | val eq : t 125 | val neq : t 126 | val ltint : t 127 | val leint : t 128 | val gtint : t 129 | val geint : t 130 | val ultint : t 131 | val ugeint : t 132 | val beq : t 133 | val bneq : t 134 | val bltint : t 135 | val bleint : t 136 | val bgtint : t 137 | val bgeint : t 138 | val bultint : t 139 | val bugeint : t 140 | val offsetint : int32 -> t 141 | val offsetref : int32 -> t 142 | val isint : t 143 | val getmethod : t 144 | val getpubmet : int32 -> t 145 | val getdynmet : int32 -> t 146 | val stop : t 147 | val event : t 148 | val break : t 149 | val to_array : t list -> int32 array 150 | -------------------------------------------------------------------------------- /src/interp.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module type State = sig 4 | type st 5 | 6 | include Ops.S 7 | 8 | (* machine registers *) 9 | 10 | val get_reg : st -> Machine.Register.t -> t * st 11 | val set_reg : st -> Machine.Register.t -> t -> st 12 | 13 | (* memory access *) 14 | 15 | val get_mem : st -> Machine.Cache.t -> t -> t * st 16 | val set_mem : st -> Machine.Cache.t -> t -> t -> st 17 | 18 | (* control *) 19 | 20 | val cond : st -> t -> (st -> unit * st) -> (st -> unit * st) -> st 21 | val iter_up : st -> t -> t -> (t -> st -> unit * st) -> st 22 | val iter_dn : st -> t -> t -> (t -> st -> unit * st) -> st 23 | 24 | (* oo *) 25 | 26 | val dynmet : st -> t -> t -> t * st 27 | 28 | (* debugging *) 29 | 30 | val string_of_value : t -> string 31 | end 32 | 33 | module State_eval : State with type t = int64 and type st = Machine.state 34 | 35 | type sp_cmd = 36 | | Get_reg of int * Machine.Register.t 37 | | Set_reg of Machine.Register.t * sp_t 38 | | Get_mem of int * Machine.Cache.t * sp_t 39 | | Set_mem of Machine.Cache.t * sp_t * sp_t 40 | | Cond of sp_t * sp_cmd list * sp_cmd list 41 | | Iter of bool * int * sp_t * sp_t * sp_cmd list 42 | 43 | and sp_t = 44 | | Op of string * sp_t * sp_t 45 | | Val of int 46 | | Const of int 47 | 48 | and sp_st = 49 | { id : int 50 | ; cmd : sp_cmd list 51 | } 52 | [@@deriving sexp_of] 53 | 54 | module State_poly : sig 55 | include State with type t = sp_t and type st = sp_st 56 | 57 | val empty : st 58 | val normalise : sp_cmd list -> sp_cmd list 59 | val print : st -> unit 60 | end 61 | 62 | module type Monad = sig 63 | module S : State 64 | 65 | type 'a t = S.st -> 'a * S.st 66 | 67 | val bind : 'a t -> ('a -> 'b t) -> 'b t 68 | val return : 'a -> 'a t 69 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 70 | val ( >> ) : 'a t -> 'b t -> 'b t 71 | val if_ : S.t -> unit t -> unit t -> unit t 72 | val for_up : S.t -> S.t -> (S.t -> unit t) -> unit t 73 | val for_dn : S.t -> S.t -> (S.t -> unit t) -> unit t 74 | val step : S.st -> 'a t -> 'a * S.st 75 | val trace : bool 76 | val debug : string -> unit t 77 | val write_reg : Machine.Register.t -> S.t -> unit t 78 | val read_reg : Machine.Register.t -> S.t t 79 | val modify_reg : Machine.Register.t -> (S.t -> S.t) -> unit t 80 | val read_mem : Machine.Cache.t -> S.t -> S.t t 81 | val write_mem : Machine.Cache.t -> S.t -> S.t -> unit t 82 | val read_bytecode : S.t -> S.t t 83 | val dynmet : S.t -> S.t -> S.t t 84 | end 85 | 86 | module Monad (T : sig 87 | val trace : bool 88 | end) 89 | (S : State) : Monad with type S.st = S.st and type S.t = S.t 90 | 91 | module Opcodes (M : Monad) : sig 92 | type returns = 93 | [ `step 94 | | `stop 95 | | `c_call of M.S.t * M.S.t 96 | ] 97 | [@@deriving sexp_of] 98 | 99 | type instr = unit M.t 100 | type arg = M.S.t 101 | 102 | val accn : arg -> instr 103 | val acc : instr 104 | val push : instr 105 | val pushaccn : arg -> instr 106 | val pushacc : instr 107 | val pop : instr 108 | val assign : instr 109 | val envaccn : arg -> instr 110 | val envacc : instr 111 | val pushenvaccn : arg -> instr 112 | val pushenvacc : instr 113 | val push_retaddr : instr 114 | val apply : instr 115 | val applyn : int -> instr 116 | val appterm : instr 117 | val apptermn : int -> instr 118 | val return_ : instr 119 | val restart : instr 120 | val grab : instr 121 | val closure : instr 122 | val closurerec : instr 123 | val pushoffsetclosure : instr 124 | val offsetclosure : instr 125 | val pushoffsetclosurem2 : instr 126 | val offsetclosurem2 : instr 127 | val pushoffsetclosure0 : instr 128 | val offsetclosure0 : instr 129 | val pushoffsetclosure2 : instr 130 | val offsetclosure2 : instr 131 | val getglobal : instr 132 | val pushgetglobal : instr 133 | val getglobalfield : instr 134 | val pushgetglobalfield : instr 135 | val setglobal : instr 136 | val atom0 : instr 137 | val pushatom0 : instr 138 | val atom : instr 139 | val pushatom : instr 140 | val makeblockn : arg -> instr 141 | val makeblock : instr 142 | val makefloatblock : instr 143 | val getfieldn : arg -> instr 144 | val getfield : instr 145 | val getfloatfield : instr 146 | val setfieldn : arg -> instr 147 | val setfield : instr 148 | val vectlength : instr 149 | val getvectitem : instr 150 | val setvectitem : instr 151 | val getstringchar : instr 152 | val setstringchar : instr 153 | val branch : instr 154 | val branchif : instr 155 | val branchifnot : instr 156 | val switch : instr 157 | val boolnot : instr 158 | val pushtrap : instr 159 | val poptrap : instr 160 | val raise_ : instr 161 | val raise_notrace : instr 162 | val reraise : instr 163 | val check_signals : instr 164 | val c_call : arg -> returns M.t 165 | val c_calln : returns M.t 166 | val constn : arg -> instr 167 | val pushconstn : arg -> instr 168 | val constint : instr 169 | val pushconstint : instr 170 | val negint : instr 171 | val addint : instr 172 | val subint : instr 173 | val mulint : instr 174 | val divint : instr 175 | val modint : instr 176 | val andint : instr 177 | val orint : instr 178 | val xorint : instr 179 | val lslint : instr 180 | val lsrint : instr 181 | val asrint : instr 182 | val eq : instr 183 | val neq : instr 184 | val ltint : instr 185 | val leint : instr 186 | val gtint : instr 187 | val geint : instr 188 | val ultint : instr 189 | val ugeint : instr 190 | val beq : instr 191 | val bneq : instr 192 | val bltint : instr 193 | val bleint : instr 194 | val bgtint : instr 195 | val bgeint : instr 196 | val bultint : instr 197 | val bugeint : instr 198 | val offsetint : instr 199 | val offsetref : instr 200 | val isint : instr 201 | val getmethod : instr 202 | val getdynmet : instr 203 | val getpubmet : instr 204 | val stop : instr 205 | val event : instr 206 | val break : instr 207 | val dispatch : Opcode.t -> returns M.t 208 | end 209 | -------------------------------------------------------------------------------- /src/load.ml: -------------------------------------------------------------------------------- 1 | (* XXX copied from bytecomp/symtable.ml - MUST MATCH EXACTLY *) 2 | (* type 'a numtable = 3 | * { num_cnt: int; (\* The next number *\) 4 | * num_tbl: ('a, int) Tbl.t } (\* The table of already numbered objects *\) *) 5 | open Base 6 | module Gc = Caml.Gc 7 | module Digest = Caml.Digest 8 | module Obj = Caml.Obj 9 | module Marshal = Caml.Marshal 10 | 11 | type digest = (Digest.t[@sexp.opaque]) [@@deriving sexp_of] 12 | type code = (Int32.t array[@sexp.opaque]) [@@deriving sexp_of] 13 | 14 | type bytecode_exe = 15 | { toc : (string * int) list 16 | ; crcs : (string * digest option) list 17 | ; dplt : string 18 | ; dlls : string 19 | ; code : code 20 | ; prim : string array 21 | ; data : string 22 | } 23 | [@@deriving sexp_of] 24 | 25 | let empty = 26 | { toc = [] 27 | ; crcs = [] 28 | ; dplt = "" 29 | ; dlls = "" 30 | ; code = [||] 31 | ; prim = [||] 32 | ; data = "" (* symb = None; *) 33 | } 34 | ;; 35 | 36 | let prims str = 37 | let pos = ref 0 in 38 | let prims = ref [] in 39 | while !pos < String.length str do 40 | let i = String.index_from_exn str !pos '\000' in 41 | prims := String.sub str ~pos:!pos ~len:(i - !pos) :: !prims; 42 | pos := i + 1 43 | done; 44 | Array.of_list @@ List.rev !prims 45 | ;; 46 | 47 | let byte_codes str = 48 | let len = String.length str in 49 | Array.init (len / 4) ~f:(fun i -> 50 | let a = 51 | Array.init 4 ~f:(fun j -> 52 | Int32.shift_left (Int32.of_int_exn (Char.to_int str.[(i * 4) + j])) (j * 8)) 53 | in 54 | Array.fold a ~init:0l ~f:Int32.( lor )) 55 | ;; 56 | 57 | let get_global_data64 exe offset = 58 | Repr.to_data64 (Repr.of_obj (Obj.repr (Marshal.from_string exe.data 0))) offset 59 | ;; 60 | 61 | let bytecode_exe exe_name = 62 | Symtable.reset (); 63 | Bytesections.reset (); 64 | let f = Stdio.In_channel.create exe_name in 65 | Bytesections.read_toc f; 66 | let toc = Bytesections.toc () in 67 | let str s = 68 | try Bytesections.read_section_string f s with 69 | | Caml.Not_found -> "" 70 | in 71 | let exe = 72 | { toc 73 | ; crcs = 74 | (Obj.magic (Bytesections.read_section_struct f "CRCS") : (string 75 | * Digest.t option) 76 | list) 77 | ; dplt = str "DPLT" 78 | ; dlls = str "DLLS" 79 | ; code = byte_codes (str "CODE") 80 | ; prim = prims (str "PRIM") 81 | ; data = 82 | str "DATA" 83 | (* symb = 84 | * Some 85 | * ( Obj.magic (Bytesections.read_section_struct f "SYMB") 86 | * : Ident.t numtable ); *) 87 | } 88 | in 89 | Stdio.In_channel.close f; 90 | Gc.major (); 91 | exe 92 | ;; 93 | -------------------------------------------------------------------------------- /src/load.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type bytecode_exe = 4 | { toc : (string * int) list 5 | ; crcs : (string * Caml.Digest.t option) list 6 | ; dplt : string 7 | ; dlls : string 8 | ; code : Int32.t array 9 | ; prim : string array 10 | ; data : string 11 | } 12 | [@@deriving sexp_of] 13 | 14 | (* XXX We used to have a symb field of numtable entries, but OCaml seems to have 15 | changed here and we weren't actually using it - probably more for debug then 16 | anything else. *) 17 | 18 | val empty : bytecode_exe 19 | val get_global_data64 : bytecode_exe -> int -> int64 array 20 | val bytecode_exe : string -> bytecode_exe 21 | -------------------------------------------------------------------------------- /src/machine.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Register = struct 4 | module T = struct 5 | (* zinc registers *) 6 | type t = 7 | | Accu 8 | | Env 9 | | Pc 10 | | Sp 11 | | Extra_args 12 | | Trapsp 13 | | Global_data 14 | | Atom_table 15 | | Alloc_base 16 | | Stack_high 17 | [@@deriving equal, compare, sexp_of, enumerate, variants] 18 | end 19 | 20 | include T 21 | include Comparator.Make (T) 22 | end 23 | 24 | module Cache = struct 25 | module T = struct 26 | type t = 27 | | Stack 28 | | Program 29 | | Mem 30 | [@@deriving equal, compare, sexp_of, enumerate, variants] 31 | end 32 | 33 | include T 34 | include Comparator.Make (T) 35 | end 36 | 37 | type memory_mapping = 38 | { code_address : int 39 | ; code_size : int 40 | ; atoms_address : int 41 | ; globals_address : int 42 | ; c_heap_address : int 43 | ; c_heap_size : int 44 | ; heap_address : int 45 | ; stack_address : int 46 | } 47 | 48 | type state = 49 | { (* zinc registers *) 50 | accu : int64 51 | ; env : int64 52 | ; pc : int64 53 | ; sp : int64 54 | ; extra_args : int64 55 | ; trapsp : int64 56 | ; (* other state *) 57 | global_data : int64 58 | ; atom_table : int64 59 | ; alloc_base : int64 60 | ; stack_high : int64 61 | ; (* memory *) 62 | memory : Memory.t 63 | ; (* executable *) 64 | exe : Load.bytecode_exe 65 | ; mapping : memory_mapping 66 | } 67 | 68 | let empty = 69 | let memory = Bigarray.(Array1.create int64 c_layout 0) in 70 | { accu = 0L 71 | ; env = 0L 72 | ; pc = 0L 73 | ; sp = 0L 74 | ; extra_args = 0L 75 | ; trapsp = 0L 76 | ; global_data = 0L 77 | ; atom_table = 0L 78 | ; alloc_base = 0L 79 | ; stack_high = 0L 80 | ; memory 81 | ; exe = Load.empty 82 | ; mapping = 83 | { code_address = 0 84 | ; code_size = 0 85 | ; atoms_address = 0 86 | ; globals_address = 0 87 | ; c_heap_address = 0 88 | ; c_heap_size = 0 89 | ; heap_address = 0 90 | ; stack_address = 0 91 | } 92 | } 93 | ;; 94 | 95 | let string_of_mach_reg : Register.t -> String.t = function 96 | | Accu -> "accu" 97 | | Env -> "env" 98 | | Pc -> "pc" 99 | | Sp -> "sp" 100 | | Extra_args -> "extra_args" 101 | | Trapsp -> "trapsp" 102 | | Global_data -> "global_data" 103 | | Atom_table -> "atom_table" 104 | | Alloc_base -> "alloc_base" 105 | | Stack_high -> "stack_high" 106 | ;; 107 | 108 | let string_of_cache : Cache.t -> String.t = function 109 | | Stack -> "stack" 110 | | Program -> "program" 111 | | Mem -> "mem" 112 | ;; 113 | 114 | let num_machine_registers = List.length Register.all 115 | let num_cache_spaces = List.length Cache.all 116 | -------------------------------------------------------------------------------- /src/machine.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Register : sig 4 | (* zinc registers *) 5 | type t = 6 | | Accu 7 | | Env 8 | | Pc 9 | | Sp 10 | | Extra_args 11 | | Trapsp 12 | | Global_data 13 | | Atom_table 14 | | Alloc_base 15 | | Stack_high 16 | [@@deriving equal, compare, sexp_of, enumerate, variants] 17 | 18 | include Comparator.S with type t := t 19 | end 20 | 21 | module Cache : sig 22 | type t = 23 | | Stack 24 | | Program 25 | | Mem 26 | [@@deriving equal, compare, sexp_of, enumerate, variants] 27 | 28 | include Comparator.S with type t := t 29 | end 30 | 31 | type memory_mapping = 32 | { code_address : int 33 | ; code_size : int 34 | ; atoms_address : int 35 | ; globals_address : int 36 | ; c_heap_address : int 37 | ; c_heap_size : int 38 | ; heap_address : int 39 | ; stack_address : int 40 | } 41 | 42 | type state = 43 | { (* zinc registers *) 44 | accu : int64 45 | ; env : int64 46 | ; pc : int64 47 | ; sp : int64 48 | ; extra_args : int64 49 | ; trapsp : int64 50 | ; (* other state *) 51 | global_data : int64 52 | ; atom_table : int64 53 | ; alloc_base : int64 54 | ; stack_high : int64 55 | ; (* memory *) 56 | memory : Memory.t 57 | ; (* executable *) 58 | exe : Load.bytecode_exe 59 | ; mapping : memory_mapping 60 | } 61 | 62 | val empty : state 63 | val string_of_mach_reg : Register.t -> string 64 | val string_of_cache : Cache.t -> string 65 | val num_machine_registers : int 66 | val num_cache_spaces : int 67 | -------------------------------------------------------------------------------- /src/memory.ml: -------------------------------------------------------------------------------- 1 | type t = (Int64.t, Bigarray.int64_elt, Bigarray.c_layout) Bigarray.Array1.t 2 | -------------------------------------------------------------------------------- /src/memory.mli: -------------------------------------------------------------------------------- 1 | type t = (Int64.t, Bigarray.int64_elt, Bigarray.c_layout) Bigarray.Array1.t 2 | -------------------------------------------------------------------------------- /src/mlvalues.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | module Obj = Caml.Obj 3 | 4 | module Make (M : Ops.S) = struct 5 | open M 6 | 7 | let val_int x = sll x one |: one 8 | let val_unit = one 9 | let val_false = one 10 | let val_true = const 3 11 | let int_val x = sra x one 12 | let is_int v = v &: one 13 | let is_block v = ~:v &: one 14 | 15 | let make_header size colour tag = 16 | assert (compare tag (const 256) < 0); 17 | sll (tag &: const 255) (const 0) 18 | |: sll (colour &: const 3) (const 8) 19 | |: sll size (const 10) 20 | ;; 21 | 22 | let size hdr = srl hdr (const 10) 23 | let colour hdr = srl hdr (const 8) &: const 3 24 | let tag hdr = hdr &: const 255 25 | let white = const 0 26 | let gray = const 1 27 | let blue = const 2 28 | let black = const 3 29 | let lazy_tag = const Obj.lazy_tag 30 | let closure_tag = const Obj.closure_tag 31 | let object_tag = const Obj.object_tag 32 | let infix_tag = const Obj.infix_tag 33 | let forward_tag = const Obj.forward_tag 34 | let no_scan_tag = const Obj.no_scan_tag 35 | let abstract_tag = const Obj.abstract_tag 36 | let string_tag = const Obj.string_tag 37 | let double_tag = const Obj.double_tag 38 | let double_array_tag = const Obj.double_array_tag 39 | let custom_tag = const Obj.custom_tag 40 | end 41 | -------------------------------------------------------------------------------- /src/mlvalues.mli: -------------------------------------------------------------------------------- 1 | module Make (M : Ops.S) : sig 2 | open M 3 | 4 | val val_int : t -> t 5 | val val_unit : t 6 | val val_false : t 7 | val val_true : t 8 | val int_val : t -> t 9 | val is_int : t -> t 10 | val is_block : t -> t 11 | val make_header : t -> t -> t -> t 12 | val size : t -> t 13 | val colour : t -> t 14 | val tag : t -> t 15 | val black : t 16 | val gray : t 17 | val blue : t 18 | val white : t 19 | val lazy_tag : t 20 | val closure_tag : t 21 | val object_tag : t 22 | val infix_tag : t 23 | val forward_tag : t 24 | val no_scan_tag : t 25 | val abstract_tag : t 26 | val string_tag : t 27 | val double_tag : t 28 | val double_array_tag : t 29 | val custom_tag : t 30 | end 31 | -------------------------------------------------------------------------------- /src/opcode.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = 4 | | ACC0 5 | | ACC1 6 | | ACC2 7 | | ACC3 8 | | ACC4 9 | | ACC5 10 | | ACC6 11 | | ACC7 12 | | ACC 13 | | PUSH 14 | | PUSHACC0 15 | | PUSHACC1 16 | | PUSHACC2 17 | | PUSHACC3 18 | | PUSHACC4 19 | | PUSHACC5 20 | | PUSHACC6 21 | | PUSHACC7 22 | | PUSHACC 23 | | POP 24 | | ASSIGN 25 | | ENVACC1 26 | | ENVACC2 27 | | ENVACC3 28 | | ENVACC4 29 | | ENVACC 30 | | PUSHENVACC1 31 | | PUSHENVACC2 32 | | PUSHENVACC3 33 | | PUSHENVACC4 34 | | PUSHENVACC 35 | | PUSH_RETADDR 36 | | APPLY 37 | | APPLY1 38 | | APPLY2 39 | | APPLY3 40 | | APPTERM 41 | | APPTERM1 42 | | APPTERM2 43 | | APPTERM3 44 | | RETURN 45 | | RESTART 46 | | GRAB 47 | | CLOSURE 48 | | CLOSUREREC 49 | | OFFSETCLOSUREM2 50 | | OFFSETCLOSURE0 51 | | OFFSETCLOSURE2 52 | | OFFSETCLOSURE 53 | | PUSHOFFSETCLOSUREM2 54 | | PUSHOFFSETCLOSURE0 55 | | PUSHOFFSETCLOSURE2 56 | | PUSHOFFSETCLOSURE 57 | | GETGLOBAL 58 | | PUSHGETGLOBAL 59 | | GETGLOBALFIELD 60 | | PUSHGETGLOBALFIELD 61 | | SETGLOBAL 62 | | ATOM0 63 | | ATOM 64 | | PUSHATOM0 65 | | PUSHATOM 66 | | MAKEBLOCK 67 | | MAKEBLOCK1 68 | | MAKEBLOCK2 69 | | MAKEBLOCK3 70 | | MAKEFLOATBLOCK 71 | | GETFIELD0 72 | | GETFIELD1 73 | | GETFIELD2 74 | | GETFIELD3 75 | | GETFIELD 76 | | GETFLOATFIELD 77 | | SETFIELD0 78 | | SETFIELD1 79 | | SETFIELD2 80 | | SETFIELD3 81 | | SETFIELD 82 | | SETFLOATFIELD 83 | | VECTLENGTH 84 | | GETVECTITEM 85 | | SETVECTITEM 86 | | GETSTRINGCHAR 87 | | SETSTRINGCHAR 88 | | BRANCH 89 | | BRANCHIF 90 | | BRANCHIFNOT 91 | | SWITCH 92 | | BOOLNOT 93 | | PUSHTRAP 94 | | POPTRAP 95 | | RAISE 96 | | CHECK_SIGNALS 97 | | C_CALL1 98 | | C_CALL2 99 | | C_CALL3 100 | | C_CALL4 101 | | C_CALL5 102 | | C_CALLN 103 | | CONST0 104 | | CONST1 105 | | CONST2 106 | | CONST3 107 | | CONSTINT 108 | | PUSHCONST0 109 | | PUSHCONST1 110 | | PUSHCONST2 111 | | PUSHCONST3 112 | | PUSHCONSTINT 113 | | NEGINT 114 | | ADDINT 115 | | SUBINT 116 | | MULINT 117 | | DIVINT 118 | | MODINT 119 | | ANDINT 120 | | ORINT 121 | | XORINT 122 | | LSLINT 123 | | LSRINT 124 | | ASRINT 125 | | EQ 126 | | NEQ 127 | | LTINT 128 | | LEINT 129 | | GTINT 130 | | GEINT 131 | | OFFSETINT 132 | | OFFSETREF 133 | | ISINT 134 | | GETMETHOD 135 | | BEQ 136 | | BNEQ 137 | | BLTINT 138 | | BLEINT 139 | | BGTINT 140 | | BGEINT 141 | | ULTINT 142 | | UGEINT 143 | | BULTINT 144 | | BUGEINT 145 | | GETPUBMET 146 | | GETDYNMET 147 | | STOP 148 | | EVENT 149 | | BREAK 150 | | RERAISE 151 | | RAISE_NOTRACE 152 | [@@deriving equal, compare, sexp_of, variants, enumerate] 153 | 154 | let to_int opcode = Variants.to_rank opcode 155 | 156 | let of_int = 157 | let map = 158 | all 159 | |> List.map ~f:(fun opcode -> to_int opcode, opcode) 160 | |> Map.of_alist_exn (module Int) 161 | in 162 | Map.find_exn map 163 | ;; 164 | 165 | let to_string opcode = sexp_of_t opcode |> Sexp.to_string_hum 166 | -------------------------------------------------------------------------------- /src/opcode.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = 4 | | ACC0 5 | | ACC1 6 | | ACC2 7 | | ACC3 8 | | ACC4 9 | | ACC5 10 | | ACC6 11 | | ACC7 12 | | ACC 13 | | PUSH 14 | | PUSHACC0 15 | | PUSHACC1 16 | | PUSHACC2 17 | | PUSHACC3 18 | | PUSHACC4 19 | | PUSHACC5 20 | | PUSHACC6 21 | | PUSHACC7 22 | | PUSHACC 23 | | POP 24 | | ASSIGN 25 | | ENVACC1 26 | | ENVACC2 27 | | ENVACC3 28 | | ENVACC4 29 | | ENVACC 30 | | PUSHENVACC1 31 | | PUSHENVACC2 32 | | PUSHENVACC3 33 | | PUSHENVACC4 34 | | PUSHENVACC 35 | | PUSH_RETADDR 36 | | APPLY 37 | | APPLY1 38 | | APPLY2 39 | | APPLY3 40 | | APPTERM 41 | | APPTERM1 42 | | APPTERM2 43 | | APPTERM3 44 | | RETURN 45 | | RESTART 46 | | GRAB 47 | | CLOSURE 48 | | CLOSUREREC 49 | | OFFSETCLOSUREM2 50 | | OFFSETCLOSURE0 51 | | OFFSETCLOSURE2 52 | | OFFSETCLOSURE 53 | | PUSHOFFSETCLOSUREM2 54 | | PUSHOFFSETCLOSURE0 55 | | PUSHOFFSETCLOSURE2 56 | | PUSHOFFSETCLOSURE 57 | | GETGLOBAL 58 | | PUSHGETGLOBAL 59 | | GETGLOBALFIELD 60 | | PUSHGETGLOBALFIELD 61 | | SETGLOBAL 62 | | ATOM0 63 | | ATOM 64 | | PUSHATOM0 65 | | PUSHATOM 66 | | MAKEBLOCK 67 | | MAKEBLOCK1 68 | | MAKEBLOCK2 69 | | MAKEBLOCK3 70 | | MAKEFLOATBLOCK 71 | | GETFIELD0 72 | | GETFIELD1 73 | | GETFIELD2 74 | | GETFIELD3 75 | | GETFIELD 76 | | GETFLOATFIELD 77 | | SETFIELD0 78 | | SETFIELD1 79 | | SETFIELD2 80 | | SETFIELD3 81 | | SETFIELD 82 | | SETFLOATFIELD 83 | | VECTLENGTH 84 | | GETVECTITEM 85 | | SETVECTITEM 86 | | GETSTRINGCHAR 87 | | SETSTRINGCHAR 88 | | BRANCH 89 | | BRANCHIF 90 | | BRANCHIFNOT 91 | | SWITCH 92 | | BOOLNOT 93 | | PUSHTRAP 94 | | POPTRAP 95 | | RAISE 96 | | CHECK_SIGNALS 97 | | C_CALL1 98 | | C_CALL2 99 | | C_CALL3 100 | | C_CALL4 101 | | C_CALL5 102 | | C_CALLN 103 | | CONST0 104 | | CONST1 105 | | CONST2 106 | | CONST3 107 | | CONSTINT 108 | | PUSHCONST0 109 | | PUSHCONST1 110 | | PUSHCONST2 111 | | PUSHCONST3 112 | | PUSHCONSTINT 113 | | NEGINT 114 | | ADDINT 115 | | SUBINT 116 | | MULINT 117 | | DIVINT 118 | | MODINT 119 | | ANDINT 120 | | ORINT 121 | | XORINT 122 | | LSLINT 123 | | LSRINT 124 | | ASRINT 125 | | EQ 126 | | NEQ 127 | | LTINT 128 | | LEINT 129 | | GTINT 130 | | GEINT 131 | | OFFSETINT 132 | | OFFSETREF 133 | | ISINT 134 | | GETMETHOD 135 | | BEQ 136 | | BNEQ 137 | | BLTINT 138 | | BLEINT 139 | | BGTINT 140 | | BGEINT 141 | | ULTINT 142 | | UGEINT 143 | | BULTINT 144 | | BUGEINT 145 | | GETPUBMET 146 | | GETDYNMET 147 | | STOP 148 | | EVENT 149 | | BREAK 150 | | RERAISE 151 | | RAISE_NOTRACE 152 | [@@deriving equal, compare, enumerate, sexp_of] 153 | 154 | val to_int : t -> int 155 | val of_int : int -> t 156 | val to_string : t -> string 157 | -------------------------------------------------------------------------------- /src/ops.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module type S = sig 4 | type t [@@deriving equal, compare] 5 | 6 | val const : int -> t 7 | val zero : t 8 | val one : t 9 | val ( +: ) : t -> t -> t 10 | val ( -: ) : t -> t -> t 11 | val ( *: ) : t -> t -> t 12 | val ( /: ) : t -> t -> t 13 | val ( %: ) : t -> t -> t 14 | val ( &: ) : t -> t -> t 15 | val ( |: ) : t -> t -> t 16 | val ( ^: ) : t -> t -> t 17 | val ( ~: ) : t -> t 18 | val sll : t -> t -> t 19 | val srl : t -> t -> t 20 | val sra : t -> t -> t 21 | val ( ==: ) : t -> t -> t 22 | val ( <>: ) : t -> t -> t 23 | val ( <+ ) : t -> t -> t 24 | val ( <=+ ) : t -> t -> t 25 | val ( >+ ) : t -> t -> t 26 | val ( >=+ ) : t -> t -> t 27 | val ( <: ) : t -> t -> t 28 | val ( <=: ) : t -> t -> t 29 | val ( >: ) : t -> t -> t 30 | val ( >=: ) : t -> t -> t 31 | end 32 | 33 | module Int64 = struct 34 | type t = Int64.t [@@deriving equal, compare] 35 | 36 | let const = Int64.of_int 37 | let zero = 0L 38 | let one = 1L 39 | let ( +: ) a b = Int64.(a + b) 40 | let ( -: ) a b = Int64.(a - b) 41 | let ( *: ) a b = Int64.(a * b) 42 | let ( /: ) a b = Int64.(a / b) 43 | let ( %: ) a b = Int64.(a % b) 44 | let ( &: ) a b = Int64.(a land b) 45 | let ( |: ) a b = Int64.(a lor b) 46 | let ( ^: ) a b = Int64.(a lxor b) 47 | let ( ~: ) a = Int64.(lnot a) 48 | let sll a b = Int64.shift_left a (Int64.to_int_exn b) 49 | let srl a b = Int64.shift_right_logical a (Int64.to_int_exn b) 50 | let sra a b = Int64.shift_right a (Int64.to_int_exn b) 51 | let ( ==: ) a b = if Int64.equal a b then 1L else 0L 52 | let ( <>: ) a b = if not (Int64.equal a b) then 1L else 0L 53 | let ( <+ ) a b = if Int64.compare a b < 0 then 1L else 0L 54 | let ( <=+ ) a b = if Int64.compare a b <= 0 then 1L else 0L 55 | let ( >+ ) a b = if Int64.compare a b > 0 then 1L else 0L 56 | let ( >=+ ) a b = if Int64.compare a b >= 0 then 1L else 0L 57 | let mask = 0x8000_0000_0000_0000L 58 | let ( <: ) a b = a ^: mask <+ b ^: mask 59 | let ( <=: ) a b = a ^: mask <=+ b ^: mask 60 | let ( >: ) a b = a ^: mask >+ b ^: mask 61 | let ( >=: ) a b = a ^: mask >=+ b ^: mask 62 | end 63 | -------------------------------------------------------------------------------- /src/ops.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module type S = sig 4 | type t [@@deriving equal, compare] 5 | 6 | val const : int -> t 7 | val zero : t 8 | val one : t 9 | val ( +: ) : t -> t -> t 10 | val ( -: ) : t -> t -> t 11 | val ( *: ) : t -> t -> t 12 | val ( /: ) : t -> t -> t 13 | val ( %: ) : t -> t -> t 14 | val ( &: ) : t -> t -> t 15 | val ( |: ) : t -> t -> t 16 | val ( ^: ) : t -> t -> t 17 | val ( ~: ) : t -> t 18 | val sll : t -> t -> t 19 | val srl : t -> t -> t 20 | val sra : t -> t -> t 21 | val ( ==: ) : t -> t -> t 22 | val ( <>: ) : t -> t -> t 23 | val ( <+ ) : t -> t -> t 24 | val ( <=+ ) : t -> t -> t 25 | val ( >+ ) : t -> t -> t 26 | val ( >=+ ) : t -> t -> t 27 | val ( <: ) : t -> t -> t 28 | val ( <=: ) : t -> t -> t 29 | val ( >: ) : t -> t -> t 30 | val ( >=: ) : t -> t -> t 31 | end 32 | 33 | module Int64 : S with type t = int64 34 | -------------------------------------------------------------------------------- /src/repr.ml: -------------------------------------------------------------------------------- 1 | (* Do deeply shocking things with Obj. *) 2 | open Base 3 | module Obj = Caml.Obj 4 | 5 | type t = 6 | | Flat of 7 | { header : Int64.t 8 | ; data : Int64.Hex.t array 9 | } 10 | | Block of 11 | { header : Int64.t 12 | ; data : t array 13 | } 14 | | Int of Int64.t 15 | [@@deriving sexp_of] 16 | 17 | module M = Mlvalues.Make (Ops.Int64) 18 | 19 | (* !!!danger!!! *) 20 | let obj_of_int64 i = 21 | let x = Obj.repr Int64.(to_int_exn (shift_right i 1)) in 22 | if Int64.(i land 1L = 1L) then x else Obj.add_offset x (-1l) 23 | ;; 24 | 25 | let int64_of_obj o = 26 | let bitlo = if Obj.is_int o then 1L else 0L in 27 | let valhi = Int64.of_int (Obj.magic o : int) in 28 | Int64.(shift_left valhi 1 lor bitlo) 29 | ;; 30 | 31 | let rec of_obj ?(closure = true) o = 32 | if Obj.is_block o 33 | then ( 34 | let tag, size = Obj.tag o, Obj.size o in 35 | if (not closure) && tag = Obj.closure_tag 36 | then Int M.val_unit 37 | else if tag < Obj.no_scan_tag 38 | then 39 | Block 40 | { header = M.make_header (Int64.of_int size) M.white (Int64.of_int tag) 41 | ; data = Array.(init size ~f:(fun i -> of_obj ~closure (Obj.field o i))) 42 | } 43 | else 44 | Flat 45 | { header = M.make_header (Int64.of_int size) M.white (Int64.of_int tag) 46 | ; data = Array.(init size ~f:(fun i -> int64_of_obj (Obj.field o i))) 47 | }) 48 | else Int Int64.(shift_left (of_int (Obj.magic o : int)) 1 lor 1L) 49 | ;; 50 | 51 | let rec to_obj r = 52 | match r with 53 | | Int i -> Obj.repr Int64.(to_int_exn (shift_right i 1)) 54 | | Flat { header = h; data = d } -> 55 | let size = Array.length d in 56 | let tag = M.tag h in 57 | let b = Obj.new_block (Int64.to_int_exn tag) size in 58 | (* empty? *) 59 | for i = 0 to size - 1 do 60 | Obj.set_field b i (obj_of_int64 d.(i)) 61 | done; 62 | b 63 | | Block { header = h; data = d } -> 64 | let size = Array.length d in 65 | let tag = M.tag h in 66 | let b = Obj.new_block (Int64.to_int_exn tag) size in 67 | (* empty? *) 68 | for i = 0 to size - 1 do 69 | Obj.set_field b i (to_obj d.(i)) 70 | done; 71 | b 72 | ;; 73 | 74 | let to_data64 data base_word_offset = 75 | let is_int = function 76 | | Int v -> Some v 77 | | _ -> None 78 | in 79 | let rec size = function 80 | | Int _ -> 1 81 | | Flat { data; _ } -> 1 + Array.length data 82 | | Block { data; _ } -> 83 | 1 84 | + Array.fold data ~init:0 ~f:(fun acc x -> 85 | acc 86 | + 87 | match is_int x with 88 | | None -> 1 + size x 89 | | _ -> 1) 90 | in 91 | let size = size data in 92 | let arr = Array.init size ~f:(fun _ -> 0L) in 93 | let pos = ref 0 in 94 | let push d = 95 | let p = !pos in 96 | arr.(p) <- d; 97 | Int.incr pos; 98 | p 99 | in 100 | let rec layout = function 101 | | Int int_val -> push int_val 102 | | Flat { header; data } -> 103 | let size = Array.length data in 104 | let base = push header in 105 | for i = 0 to size - 1 do 106 | ignore @@ push data.(i) 107 | done; 108 | base 109 | | Block { header; data } -> 110 | let size = Array.length data in 111 | let base = push header in 112 | let resv = Array.init size ~f:(fun _ -> push 0L) in 113 | (* reserve locations *) 114 | for i = 0 to size - 1 do 115 | match is_int data.(i) with 116 | | Some v -> arr.(resv.(i)) <- v 117 | | None -> 118 | let ptr = layout data.(i) in 119 | (* convert to pointer, offset by base *) 120 | arr.(resv.(i)) <- Int64.of_int ((base_word_offset + ptr + 1) lsl 3) 121 | done; 122 | base 123 | in 124 | let (_ : int) = layout data in 125 | assert (size = !pos); 126 | arr 127 | ;; 128 | 129 | let of_data64 ?(closure = true) d p = 130 | let rec f p = 131 | if Int64.equal (M.is_block p) 1L 132 | then ( 133 | let p' = Int64.to_int_exn p / 8 in 134 | let header = d.{p' - 1} in 135 | let tag = M.tag header in 136 | let size = M.size header in 137 | if (not closure) && Int64.equal tag M.closure_tag 138 | then Int M.val_unit 139 | else if Int64.compare tag M.no_scan_tag < 0 140 | then 141 | Block 142 | { header; data = Array.init (Int64.to_int_exn size) ~f:(fun i -> f d.{p' + i}) } 143 | else 144 | Flat 145 | { header; data = Array.init (Int64.to_int_exn size) ~f:(fun i -> d.{p' + i}) }) 146 | else Int p 147 | in 148 | f p 149 | ;; 150 | -------------------------------------------------------------------------------- /src/repr.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | module Obj = Caml.Obj 3 | 4 | (** intermediate representation of ocaml memory values *) 5 | type t = 6 | | Flat of 7 | { header : Int64.t 8 | ; data : Int64.t array 9 | } 10 | | Block of 11 | { header : Int64.t 12 | ; data : t array 13 | } 14 | | Int of Int64.t 15 | [@@deriving sexp_of] 16 | 17 | (** bit pattern of an obj, including the low order hidden bit *) 18 | val int64_of_obj : Obj.t -> int64 19 | 20 | (** convert [Obj.t] to [t]. If closure is false, then blocks with closure tags 21 | are converted to unit *) 22 | val of_obj : ?closure:bool -> Obj.t -> t 23 | 24 | (** convert [t] to [Obj.t] *) 25 | val to_obj : t -> Obj.t 26 | 27 | (** int64 array of [t]. Internally pointers are offset. *) 28 | val to_data64 : t -> int -> int64 array 29 | 30 | (** [t] of int64 array **) 31 | val of_data64 : ?closure:bool -> Memory.t -> int64 -> t 32 | -------------------------------------------------------------------------------- /src/trace.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Machine 3 | module M = Mlvalues.Make (Ops.Int64) 4 | 5 | let fprintf = Stdio.Out_channel.fprintf 6 | let header memory v = memory.{(Int64.to_int_exn v / 8) - 1} 7 | let field memory v i = memory.{(Int64.to_int_exn v / 8) + i} 8 | 9 | let get_string memory v = 10 | let size = Int64.to_int_exn @@ M.size (header memory v) in 11 | let pad = 12 | Int64.to_int_exn @@ Int64.shift_right_logical (field memory v (size - 1)) 56 13 | in 14 | String.init 15 | ((size * 8) - pad - 1) 16 | ~f:(fun i -> 17 | Char.of_int_exn 18 | (Int64.to_int_exn 19 | @@ Int64.( land ) 0xFFL 20 | @@ Int64.shift_right_logical (field memory v (i / 8)) (i % 8 * 8))) 21 | ;; 22 | 23 | let showfields = ref false 24 | 25 | let root ?(chan = Stdio.Out_channel.stdout) st v = 26 | let open Ops.Int64 in 27 | let in_program v = 28 | let v = Int64.to_int_exn v in 29 | v >= st.mapping.code_address && v <= st.mapping.code_address + st.mapping.code_size 30 | in 31 | let rec f pad v = 32 | let get i = st.memory.{Int64.to_int_exn i / 8} in 33 | if Int64.equal (M.is_int v) 1L 34 | then fprintf chan "%si%Li\n" pad (M.int_val v) 35 | else if in_program v 36 | then 37 | fprintf chan "%sc%Li\n" pad (srl (v -: Int64.of_int_exn st.mapping.code_address) 2L) 38 | else ( 39 | let npad = " " ^ pad in 40 | let hdr = get (v -: 8L) in 41 | let tag = M.tag hdr in 42 | let size = M.size hdr in 43 | fprintf chan "%s[t%Li s%Li] p%.16Lx\n" pad tag size v; 44 | if Int64.equal tag M.string_tag 45 | then fprintf chan "%ss'%s'\n" pad (get_string st.memory v) 46 | else if Int64.compare tag M.no_scan_tag < 0 47 | then 48 | for i = 0 to Int64.to_int_exn size - 1 do 49 | f npad (get (v +: Int64.of_int (i * 8))) 50 | done 51 | else 52 | for i = 0 to Int64.to_int_exn size - 1 do 53 | fprintf chan "%sd%.16Lx\n" npad (get (v +: Int64.of_int (i * 8))) 54 | done) 55 | in 56 | f "" v 57 | ;; 58 | 59 | let value ?(chan = Stdio.Out_channel.stdout) st v = 60 | let open M in 61 | let sp = Int64.to_int_exn st.sp in 62 | if !showfields 63 | then fprintf chan "0x%Lx" v 64 | else fprintf chan "%c" (if Int64.equal (is_int v) 1L then 'i' else 'p'); 65 | let bytecode_address, bytecode_size = 66 | Int64.of_int st.mapping.code_address, Int64.of_int st.mapping.code_size 67 | in 68 | let codeofs v = Int64.((v - bytecode_address) / 4L) in 69 | let in_program v = 70 | Int64.(v % 4L = 0L && v >= bytecode_address && v < bytecode_address + bytecode_size) 71 | in 72 | let in_stack sp v = 73 | let v = Int64.to_int_exn v in 74 | v >= sp && v <= st.mapping.stack_address 75 | in 76 | let header, field = header st.memory, field st.memory in 77 | let printstr str = 78 | String.init 79 | (min 31 (String.length str)) 80 | ~f:(fun i -> 81 | let c = str.[i] in 82 | if Char.(c >= ' ' && c <= '~') then c else '?') 83 | in 84 | if Int64.equal (is_int v) 1L 85 | then fprintf chan "=long%Li" (Int64.shift_right v 1) 86 | else if in_program v 87 | then fprintf chan "=code@%Li" (codeofs v) 88 | else if in_stack sp v 89 | then fprintf chan "=stack_%i" ((st.mapping.stack_address - Int64.to_int_exn v) / 8) 90 | else if Int64.equal (is_block v) 1L 91 | then ( 92 | let h = header v in 93 | let tag, size = tag h, Int64.to_int_exn (size h) in 94 | let dump_fields () = 95 | if size <> 0 && !showfields 96 | then ( 97 | fprintf chan "=("; 98 | for i = 0 to min (size - 1) 20 do 99 | if i <> 0 then fprintf chan ", "; 100 | fprintf chan "0x%Lx" (field v i) 101 | done; 102 | fprintf chan ")") 103 | in 104 | let tag_is = Int64.equal tag in 105 | if tag_is closure_tag 106 | then ( 107 | fprintf chan "=closure[s%i,cod%Li]" size (codeofs (field v 0)); 108 | dump_fields ()) 109 | else if tag_is string_tag 110 | then ( 111 | let str = get_string st.memory v in 112 | fprintf chan "=string[s%iL%i]'%s'" size (String.length str) (printstr str); 113 | dump_fields ()) 114 | else if tag_is double_tag 115 | then ( 116 | fprintf chan "=float[s%i]=%g" size (Int64.float_of_bits (field v 0)); 117 | dump_fields ()) 118 | else if tag_is double_array_tag 119 | then ( 120 | fprintf chan "=floatarray[s%i]" size; 121 | dump_fields ()) 122 | else if tag_is custom_tag 123 | then ( 124 | fprintf chan "=custom[s%i]" size; 125 | dump_fields ()) 126 | else if tag_is abstract_tag 127 | then ( 128 | fprintf chan "=abstract[s%i]" size; 129 | dump_fields ()) 130 | else fprintf chan "=block" tag size) 131 | else fprintf chan "=unknown" 132 | ;; 133 | 134 | let machine ?(chan = Stdio.Out_channel.stdout) st = 135 | let sp = Int64.to_int_exn st.sp in 136 | let trapsp = Int64.to_int_exn st.trapsp in 137 | let eargs = Int64.to_int_exn st.extra_args in 138 | let stack_size = (st.mapping.stack_address - sp) / 8 in 139 | let trap_stack_size = (st.mapping.stack_address - trapsp) / 8 in 140 | fprintf chan "env="; 141 | value st st.env; 142 | fprintf chan "\n"; 143 | fprintf chan "accu="; 144 | value st st.accu; 145 | fprintf chan "\n"; 146 | if !showfields 147 | then 148 | fprintf 149 | chan 150 | " sp=0x%x @%i: trapsp=0x%x @%i extra_args=%i\n" 151 | sp 152 | stack_size 153 | trapsp 154 | trap_stack_size 155 | eargs 156 | else fprintf chan " sp=%i: trapsp=%i extra_args=%i\n" stack_size trap_stack_size eargs; 157 | for i = 0 to min (stack_size - 1) 15 do 158 | fprintf chan "[%i] " (stack_size - i); 159 | value st st.memory.{(sp / 8) + i}; 160 | fprintf chan "\n" 161 | done 162 | ;; 163 | 164 | let get_instr memory pc = 165 | let instr = memory.{pc / 2} in 166 | Ops.Int64.(sra (if pc % 2 = 0 then sll instr 32L else instr) 32L) 167 | ;; 168 | 169 | let instr ?(chan = Stdio.Out_channel.stdout) st = 170 | let pc = Int64.to_int_exn st.pc / 4 in 171 | let instr = get_instr st.memory pc in 172 | let instr = Opcode.of_int (Int64.to_int_exn instr) in 173 | let get_arg n = get_instr st.memory (pc + 1 + n) in 174 | fprintf chan "%6i %s" pc (Opcode.to_string instr); 175 | match instr with 176 | | PUSHACC 177 | | ACC 178 | | POP 179 | | ASSIGN 180 | | PUSHENVACC 181 | | ENVACC 182 | | PUSH_RETADDR 183 | | APPLY 184 | | APPTERM1 185 | | APPTERM2 186 | | APPTERM3 187 | | RETURN 188 | | GRAB 189 | | PUSHGETGLOBAL 190 | | GETGLOBAL 191 | | SETGLOBAL 192 | | PUSHATOM 193 | | ATOM 194 | | MAKEBLOCK1 195 | | MAKEBLOCK2 196 | | MAKEBLOCK3 197 | | MAKEFLOATBLOCK 198 | | GETFIELD 199 | | SETFIELD 200 | | GETFLOATFIELD 201 | | SETFLOATFIELD 202 | | BRANCH 203 | | BRANCHIF 204 | | BRANCHIFNOT 205 | | PUSHTRAP 206 | | CONSTINT 207 | | PUSHCONSTINT 208 | | OFFSETINT 209 | | OFFSETREF 210 | | OFFSETCLOSURE 211 | | PUSHOFFSETCLOSURE -> fprintf chan " %Ld\n" (get_arg 0) 212 | | APPTERM 213 | | CLOSURE 214 | | CLOSUREREC 215 | | PUSHGETGLOBALFIELD 216 | | GETGLOBALFIELD 217 | | MAKEBLOCK 218 | | BEQ 219 | | BNEQ 220 | | BLTINT 221 | | BLEINT 222 | | BGTINT 223 | | BGEINT 224 | | BULTINT 225 | | BUGEINT -> fprintf chan " %Ld, %Ld\n" (get_arg 0) (get_arg 1) 226 | | C_CALLN | C_CALL1 | C_CALL2 | C_CALL3 | C_CALL4 | C_CALL5 -> 227 | if Opcode.equal instr C_CALLN 228 | then ( 229 | fprintf chan "%Ld, " (get_arg 0); 230 | fprintf chan " %s\n" st.exe.Load.prim.(Int64.to_int_exn (get_arg 1))) 231 | else fprintf chan " %s\n" st.exe.Load.prim.(Int64.to_int_exn (get_arg 0)) 232 | | _ -> fprintf chan "\n" 233 | ;; 234 | -------------------------------------------------------------------------------- /src/trace.mli: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | val showfields : bool ref 4 | val value : ?chan:Stdio.Out_channel.t -> Machine.state -> Int64.t -> unit 5 | val machine : ?chan:Stdio.Out_channel.t -> Machine.state -> unit 6 | val root : ?chan:Stdio.Out_channel.t -> Machine.state -> Int64.t -> unit 7 | val instr : ?chan:Stdio.Out_channel.t -> Machine.state -> unit 8 | -------------------------------------------------------------------------------- /test/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name helloworld) 3 | (modes byte) 4 | ) 5 | -------------------------------------------------------------------------------- /test/examples/helloworld.ml: -------------------------------------------------------------------------------- 1 | (* Our most basic test. Just print hello world. *) 2 | 3 | let () = print_endline "Hello world!" 4 | -------------------------------------------------------------------------------- /test/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name hardcaml_zinc_test) 3 | (libraries compiler-libs.bytecomp hardcaml_waveterm hardcaml_zinc expect_test_helpers_kernel) 4 | (preprocess (pps ppx_jane ppx_expect)) 5 | (inline_tests (deps ../examples/helloworld.bc)) 6 | ) 7 | -------------------------------------------------------------------------------- /test/lib/instruction_display_rules.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Hardcaml_zinc 3 | module Sequential = Compile_hardware.Sequential 4 | 5 | let top = 6 | ( Hardcaml_waveterm.Display_rules.( 7 | Rule. 8 | [ Sequential.I.( 9 | map port_names ~f:(fun n -> port_name_is n ~wave_format:(Bit_or Unsigned_int)) 10 | |> to_list) 11 | ; Sequential.O.( 12 | map port_names ~f:(fun n -> port_name_is n ~wave_format:(Bit_or Unsigned_int)) 13 | |> to_list) 14 | ; [ port_name_is "state" ~wave_format:Unsigned_int ] 15 | ] 16 | |> List.concat 17 | |> of_list) 18 | , 80 ) 19 | ;; 20 | 21 | let create instr = 22 | let uses = Compile_hardware.Statement.Usage.create instr in 23 | let zinc_registers = 24 | Set.union 25 | (Set.of_list (module Machine.Register) uses.read_registers) 26 | (Set.of_list (module Machine.Register) uses.write_registers) 27 | |> Set.to_list 28 | in 29 | let open Hardcaml_waveterm.Display_rules in 30 | let write_memory prefix = 31 | [ Rule.port_name_is (prefix ^ "o_write") ~wave_format:Bit 32 | ; Rule.port_name_is (prefix ^ "i_write_complete") ~wave_format:Bit 33 | ; Rule.port_name_is (prefix ^ "o_write_data") ~wave_format:Unsigned_int 34 | ; Rule.port_name_is (prefix ^ "o_write_address") ~wave_format:Unsigned_int 35 | ] 36 | in 37 | let read_memory prefix = 38 | [ Rule.port_name_is (prefix ^ "o_read") ~wave_format:Bit 39 | ; Rule.port_name_is (prefix ^ "i_read_available") ~wave_format:Bit 40 | ; Rule.port_name_is (prefix ^ "i_read_data") ~wave_format:Unsigned_int 41 | ; Rule.port_name_is (prefix ^ "o_read_address") ~wave_format:Unsigned_int 42 | ] 43 | in 44 | let write_memory typ prefix = 45 | if List.mem uses.write_memories typ ~equal:Machine.Cache.equal 46 | then write_memory prefix 47 | else [] 48 | in 49 | let read_memory typ prefix = 50 | if List.mem uses.read_memories typ ~equal:Machine.Cache.equal 51 | then read_memory prefix 52 | else [] 53 | in 54 | let display_height = 55 | 7 56 | + (List.length zinc_registers * 3) 57 | + (List.length uses.write_memories * 10) 58 | + (List.length uses.read_memories * 10) 59 | in 60 | ( [ [ Rule.port_name_is "clock" ~wave_format:Bit 61 | ; Rule.port_name_is "state" ~wave_format:Unsigned_int 62 | ] 63 | ; List.map zinc_registers ~f:(fun r -> 64 | Rule.port_name_is 65 | (Machine.Register.sexp_of_t r |> Sexp.to_string_hum) 66 | ~wave_format:Unsigned_int) 67 | ; write_memory Mem "m" 68 | ; read_memory Mem "m" 69 | ; write_memory Program "p" 70 | ; read_memory Program "p" 71 | ; write_memory Stack "s" 72 | ; read_memory Stack "s" 73 | ] 74 | |> List.concat 75 | |> of_list 76 | , display_height ) 77 | ;; 78 | -------------------------------------------------------------------------------- /test/lib/instruction_display_rules.mli: -------------------------------------------------------------------------------- 1 | val top : Hardcaml_waveterm.Display_rules.t * int 2 | val create : Hardcaml_zinc.Interp.sp_cmd list -> Hardcaml_waveterm.Display_rules.t * int 3 | -------------------------------------------------------------------------------- /test/lib/test_compile.mli: -------------------------------------------------------------------------------- 1 | (* deliberately empty *) 2 | -------------------------------------------------------------------------------- /test/lib/test_loader.ml: -------------------------------------------------------------------------------- 1 | (* Load a byte code executable *) 2 | open Base 3 | open Hardcaml_zinc 4 | open Expect_test_helpers_kernel 5 | 6 | let%expect_test "load helloworld" = 7 | let bc = Load.bytecode_exe "../examples/helloworld.bc" in 8 | print_s [%message "Bytecode executable" (bc : Load.bytecode_exe)]; 9 | [%expect 10 | {| 11 | ("Bytecode executable" ( 12 | bc ( 13 | (toc ( 14 | (CODE 10568) 15 | (DLPT 0) 16 | (DLLS 0) 17 | (PRIM 7973) 18 | (DATA 604) 19 | (SYMB 352) 20 | (CRCS 1135) 21 | (DBUG 143696))) 22 | (crcs ( 23 | (Stdlib__weak ()) 24 | (Stdlib__unit ()) 25 | (Stdlib__uchar ()) 26 | (Stdlib__sys ()) 27 | (Stdlib__stringLabels ()) 28 | (Stdlib__string ()) 29 | (Stdlib__stream ()) 30 | (Stdlib__stdLabels ()) 31 | (Stdlib__stack ()) 32 | (Stdlib__spacetime ()) 33 | (Stdlib__set ()) 34 | (Stdlib__seq ()) 35 | (Stdlib__scanf ()) 36 | (Stdlib__result ()) 37 | (Stdlib__random ()) 38 | (Stdlib__queue ()) 39 | (Stdlib__printf ()) 40 | (Stdlib__printexc ()) 41 | (Stdlib__pervasives ()) 42 | (Stdlib__parsing ()) 43 | (Stdlib__option ()) 44 | (Stdlib__oo ()) 45 | (Stdlib__obj ()) 46 | (Stdlib__nativeint ()) 47 | (Stdlib__moreLabels ()) 48 | (Stdlib__marshal ()) 49 | (Stdlib__map ()) 50 | (Stdlib__listLabels ()) 51 | (Stdlib__list ()) 52 | (Stdlib__lexing ()) 53 | (Stdlib__lazy ()) 54 | (Stdlib__int64 ()) 55 | (Stdlib__int32 ()) 56 | (Stdlib__int ()) 57 | (Stdlib__hashtbl ()) 58 | (Stdlib__genlex ()) 59 | (Stdlib__gc ()) 60 | (Stdlib__fun ()) 61 | (Stdlib__format ()) 62 | (Stdlib__float ()) 63 | (Stdlib__filename ()) 64 | (Stdlib__ephemeron ()) 65 | (Stdlib__digest ()) 66 | (Stdlib__complex ()) 67 | (Stdlib__char ()) 68 | (Stdlib__callback ()) 69 | (Stdlib__bytesLabels ()) 70 | (Stdlib__bytes ()) 71 | (Stdlib__buffer ()) 72 | (Stdlib__bool ()) 73 | (Stdlib__bigarray ()) 74 | (Stdlib__arrayLabels ()) 75 | (Stdlib__array ()) 76 | (Stdlib__arg ()) 77 | (Stdlib ()) 78 | (Std_exit ()) 79 | (Dune__exe__Helloworld ()) 80 | (CamlinternalFormatBasics ()))) 81 | (dplt "") 82 | (dlls "") 83 | (code ) 84 | (prim ( 85 | caml_abs_float 86 | caml_acos_float 87 | caml_add_debug_info 88 | caml_add_float 89 | caml_alloc_dummy 90 | caml_alloc_dummy_float 91 | caml_alloc_dummy_function 92 | caml_alloc_dummy_infix 93 | caml_array_append 94 | caml_array_blit 95 | caml_array_concat 96 | caml_array_get 97 | caml_array_get_addr 98 | caml_array_get_float 99 | caml_array_set 100 | caml_array_set_addr 101 | caml_array_set_float 102 | caml_array_sub 103 | caml_array_unsafe_get 104 | caml_array_unsafe_get_float 105 | caml_array_unsafe_set 106 | caml_array_unsafe_set_addr 107 | caml_array_unsafe_set_float 108 | caml_asin_float 109 | caml_atan2_float 110 | caml_atan_float 111 | caml_ba_blit 112 | caml_ba_change_layout 113 | caml_ba_create 114 | caml_ba_dim 115 | caml_ba_dim_1 116 | caml_ba_dim_2 117 | caml_ba_dim_3 118 | caml_ba_fill 119 | caml_ba_get_1 120 | caml_ba_get_2 121 | caml_ba_get_3 122 | caml_ba_get_generic 123 | caml_ba_kind 124 | caml_ba_layout 125 | caml_ba_num_dims 126 | caml_ba_reshape 127 | caml_ba_set_1 128 | caml_ba_set_2 129 | caml_ba_set_3 130 | caml_ba_set_generic 131 | caml_ba_slice 132 | caml_ba_sub 133 | caml_ba_uint8_get16 134 | caml_ba_uint8_get32 135 | caml_ba_uint8_get64 136 | caml_ba_uint8_set16 137 | caml_ba_uint8_set32 138 | caml_ba_uint8_set64 139 | caml_backtrace_status 140 | caml_blit_bytes 141 | caml_blit_string 142 | caml_bswap16 143 | caml_bytes_compare 144 | caml_bytes_equal 145 | caml_bytes_get 146 | caml_bytes_get16 147 | caml_bytes_get32 148 | caml_bytes_get64 149 | caml_bytes_greaterequal 150 | caml_bytes_greaterthan 151 | caml_bytes_lessequal 152 | caml_bytes_lessthan 153 | caml_bytes_notequal 154 | caml_bytes_of_string 155 | caml_bytes_set 156 | caml_bytes_set16 157 | caml_bytes_set32 158 | caml_bytes_set64 159 | caml_ceil_float 160 | caml_channel_descriptor 161 | caml_classify_float 162 | caml_compare 163 | caml_convert_raw_backtrace 164 | caml_convert_raw_backtrace_slot 165 | caml_copysign_float 166 | caml_cos_float 167 | caml_cosh_float 168 | caml_create_bytes 169 | caml_create_string 170 | caml_div_float 171 | caml_dynlink_add_primitive 172 | caml_dynlink_close_lib 173 | caml_dynlink_get_current_libs 174 | caml_dynlink_lookup_symbol 175 | caml_dynlink_open_lib 176 | caml_ensure_stack_capacity 177 | caml_ephe_blit_data 178 | caml_ephe_blit_key 179 | caml_ephe_check_data 180 | caml_ephe_check_key 181 | caml_ephe_create 182 | caml_ephe_get_data 183 | caml_ephe_get_data_copy 184 | caml_ephe_get_key 185 | caml_ephe_get_key_copy 186 | caml_ephe_set_data 187 | caml_ephe_set_key 188 | caml_ephe_unset_data 189 | caml_ephe_unset_key 190 | caml_eq_float 191 | caml_equal 192 | caml_exp_float 193 | caml_expm1_float 194 | caml_fill_bytes 195 | caml_fill_string 196 | caml_final_register 197 | caml_final_register_called_without_value 198 | caml_final_release 199 | caml_float_compare 200 | caml_float_of_int 201 | caml_float_of_string 202 | caml_floatarray_create 203 | caml_floatarray_get 204 | caml_floatarray_set 205 | caml_floatarray_unsafe_get 206 | caml_floatarray_unsafe_set 207 | caml_floor_float 208 | caml_fma_float 209 | caml_fmod_float 210 | caml_format_float 211 | caml_format_int 212 | caml_fresh_oo_id 213 | caml_frexp_float 214 | caml_gc_compaction 215 | caml_gc_counters 216 | caml_gc_full_major 217 | caml_gc_get 218 | caml_gc_huge_fallback_count 219 | caml_gc_major 220 | caml_gc_major_slice 221 | caml_gc_minor 222 | caml_gc_minor_words 223 | caml_gc_quick_stat 224 | caml_gc_set 225 | caml_gc_stat 226 | caml_ge_float 227 | caml_get_current_callstack 228 | caml_get_current_environment 229 | caml_get_exception_backtrace 230 | caml_get_exception_raw_backtrace 231 | caml_get_global_data 232 | caml_get_major_bucket 233 | caml_get_major_credit 234 | caml_get_minor_free 235 | caml_get_public_method 236 | caml_get_section_table 237 | caml_greaterequal 238 | caml_greaterthan 239 | caml_gt_float 240 | caml_hash 241 | caml_hash_univ_param 242 | caml_hexstring_of_float 243 | caml_hypot_float 244 | caml_input_value 245 | caml_input_value_from_bytes 246 | caml_input_value_from_string 247 | caml_input_value_to_outside_heap 248 | caml_install_signal_handler 249 | caml_int32_add 250 | caml_int32_and 251 | caml_int32_bits_of_float 252 | caml_int32_bswap 253 | caml_int32_compare 254 | caml_int32_div 255 | caml_int32_float_of_bits 256 | caml_int32_format 257 | caml_int32_mod 258 | caml_int32_mul 259 | caml_int32_neg 260 | caml_int32_of_float 261 | caml_int32_of_int 262 | caml_int32_of_string 263 | caml_int32_or 264 | caml_int32_shift_left 265 | caml_int32_shift_right 266 | caml_int32_shift_right_unsigned 267 | caml_int32_sub 268 | caml_int32_to_float 269 | caml_int32_to_int 270 | caml_int32_xor 271 | caml_int64_add 272 | caml_int64_add_native 273 | caml_int64_and 274 | caml_int64_and_native 275 | caml_int64_bits_of_float 276 | caml_int64_bswap 277 | caml_int64_compare 278 | caml_int64_div 279 | caml_int64_div_native 280 | caml_int64_float_of_bits 281 | caml_int64_format 282 | caml_int64_mod 283 | caml_int64_mod_native 284 | caml_int64_mul 285 | caml_int64_mul_native 286 | caml_int64_neg 287 | caml_int64_neg_native 288 | caml_int64_of_float 289 | caml_int64_of_int 290 | caml_int64_of_int32 291 | caml_int64_of_nativeint 292 | caml_int64_of_string 293 | caml_int64_or 294 | caml_int64_or_native 295 | caml_int64_shift_left 296 | caml_int64_shift_right 297 | caml_int64_shift_right_unsigned 298 | caml_int64_sub 299 | caml_int64_sub_native 300 | caml_int64_to_float 301 | caml_int64_to_int 302 | caml_int64_to_int32 303 | caml_int64_to_nativeint 304 | caml_int64_xor 305 | caml_int64_xor_native 306 | caml_int_as_pointer 307 | caml_int_compare 308 | caml_int_of_float 309 | caml_int_of_string 310 | caml_invoke_traced_function 311 | caml_lazy_follow_forward 312 | caml_lazy_make_forward 313 | caml_ldexp_float 314 | caml_le_float 315 | caml_lessequal 316 | caml_lessthan 317 | caml_lex_engine 318 | caml_log10_float 319 | caml_log1p_float 320 | caml_log_float 321 | caml_lt_float 322 | caml_make_array 323 | caml_make_float_vect 324 | caml_make_vect 325 | caml_marshal_data_size 326 | caml_md5_chan 327 | caml_md5_string 328 | caml_ml_bytes_length 329 | caml_ml_channel_size 330 | caml_ml_channel_size_64 331 | caml_ml_close_channel 332 | caml_ml_enable_runtime_warnings 333 | caml_ml_flush 334 | caml_ml_flush_partial 335 | caml_ml_input 336 | caml_ml_input_char 337 | caml_ml_input_int 338 | caml_ml_input_scan_line 339 | caml_ml_open_descriptor_in 340 | caml_ml_open_descriptor_out 341 | caml_ml_out_channels_list 342 | caml_ml_output 343 | caml_ml_output_bytes 344 | caml_ml_output_char 345 | caml_ml_output_int 346 | caml_ml_output_partial 347 | caml_ml_pos_in 348 | caml_ml_pos_in_64 349 | caml_ml_pos_out 350 | caml_ml_pos_out_64 351 | caml_ml_runtime_warnings_enabled 352 | caml_ml_seek_in 353 | caml_ml_seek_in_64 354 | caml_ml_seek_out 355 | caml_ml_seek_out_64 356 | caml_ml_set_binary_mode 357 | caml_ml_set_channel_name 358 | caml_ml_string_length 359 | caml_modf_float 360 | caml_mul_float 361 | caml_nativeint_add 362 | caml_nativeint_and 363 | caml_nativeint_bswap 364 | caml_nativeint_compare 365 | caml_nativeint_div 366 | caml_nativeint_format 367 | caml_nativeint_mod 368 | caml_nativeint_mul 369 | caml_nativeint_neg 370 | caml_nativeint_of_float 371 | caml_nativeint_of_int 372 | caml_nativeint_of_int32 373 | caml_nativeint_of_string 374 | caml_nativeint_or 375 | caml_nativeint_shift_left 376 | caml_nativeint_shift_right 377 | caml_nativeint_shift_right_unsigned 378 | caml_nativeint_sub 379 | caml_nativeint_to_float 380 | caml_nativeint_to_int 381 | caml_nativeint_to_int32 382 | caml_nativeint_xor 383 | caml_neg_float 384 | caml_neq_float 385 | caml_new_lex_engine 386 | caml_nextafter_float 387 | caml_notequal 388 | caml_obj_add_offset 389 | caml_obj_block 390 | caml_obj_dup 391 | caml_obj_is_block 392 | caml_obj_make_forward 393 | caml_obj_reachable_words 394 | caml_obj_set_tag 395 | caml_obj_tag 396 | caml_obj_truncate 397 | caml_obj_with_tag 398 | caml_output_value 399 | caml_output_value_to_buffer 400 | caml_output_value_to_bytes 401 | caml_output_value_to_string 402 | caml_parse_engine 403 | caml_power_float 404 | caml_raw_backtrace_length 405 | caml_raw_backtrace_next_slot 406 | caml_raw_backtrace_slot 407 | caml_realloc_global 408 | caml_record_backtrace 409 | caml_register_channel_for_spacetime 410 | caml_register_code_fragment 411 | caml_register_named_value 412 | caml_reify_bytecode 413 | caml_remove_debug_info 414 | caml_reset_afl_instrumentation 415 | caml_restore_raw_backtrace 416 | caml_round_float 417 | caml_runtime_parameters 418 | caml_runtime_variant 419 | caml_set_oo_id 420 | caml_set_parser_trace 421 | caml_setup_afl 422 | caml_signbit 423 | caml_signbit_float 424 | caml_sin_float 425 | caml_sinh_float 426 | caml_spacetime_enabled 427 | caml_spacetime_only_works_for_native_code 428 | caml_sqrt_float 429 | caml_static_alloc 430 | caml_static_free 431 | caml_static_release_bytecode 432 | caml_static_resize 433 | caml_string_compare 434 | caml_string_equal 435 | caml_string_get 436 | caml_string_get16 437 | caml_string_get32 438 | caml_string_get64 439 | caml_string_greaterequal 440 | caml_string_greaterthan 441 | caml_string_lessequal 442 | caml_string_lessthan 443 | caml_string_notequal 444 | caml_string_of_bytes 445 | caml_string_set 446 | caml_sub_float 447 | caml_sys_argv 448 | caml_sys_chdir 449 | caml_sys_close 450 | caml_sys_const_backend_type 451 | caml_sys_const_big_endian 452 | caml_sys_const_int_size 453 | caml_sys_const_max_wosize 454 | caml_sys_const_ostype_cygwin 455 | caml_sys_const_ostype_unix 456 | caml_sys_const_ostype_win32 457 | caml_sys_const_word_size 458 | caml_sys_executable_name 459 | caml_sys_exit 460 | caml_sys_file_exists 461 | caml_sys_get_argv 462 | caml_sys_get_config 463 | caml_sys_getcwd 464 | caml_sys_getenv 465 | caml_sys_is_directory 466 | caml_sys_isatty 467 | caml_sys_modify_argv 468 | caml_sys_open 469 | caml_sys_random_seed 470 | caml_sys_read_directory 471 | caml_sys_remove 472 | caml_sys_rename 473 | caml_sys_system_command 474 | caml_sys_time 475 | caml_sys_time_include_children 476 | caml_sys_unsafe_getenv 477 | caml_tan_float 478 | caml_tanh_float 479 | caml_terminfo_rows 480 | caml_trunc_float 481 | caml_update_dummy 482 | caml_weak_blit 483 | caml_weak_check 484 | caml_weak_create 485 | caml_weak_get 486 | caml_weak_get_copy 487 | caml_weak_set)) 488 | (data 489 | "\132\149\166\190\000\000\002H\000\000\000B\000\000\001&\000\000\000\239\b\000\000\196\000\b\000\000\b\248-Out_of_memory\000\255\b\000\000\b\248)Sys_error\000\254\b\000\000\b\248'Failure\000\253\b\000\000\b\2480Invalid_argument\000\252\b\000\000\b\248+End_of_file\000\251\b\000\000\b\2480Division_by_zero\000\250\b\000\000\b\248)Not_found\000\249\b\000\000\b\248-Match_failure\000\248\b\000\000\b\248.Stack_overflow\000\247\b\000\000\b\248.Sys_blocked_io\000\246\b\000\000\b\248.Assert_failure\000\245\b\000\000\b\248:Undefined_recursive_module\000\244@\"%,,really_input%input\160@\160F@\160@\160G@0output_substring&output\160A\160C\160D\160F@\160A\160C\160D\160G@%%.12g!.\"%d%false$true\144A\144@%false$true.bool_of_string$true%false+char_of_int3index out of bounds Obj.repr |> Repr.of_obj in 22 | print_s [%message (string : Repr.t)]; 23 | [%expect 24 | {| (string (Flat (header 2300) (data (0x6f77206f6c6c6568 0x400000000646c72)))) |}] 25 | ;; 26 | 27 | type x = 28 | { a : int 29 | ; b : x option 30 | } 31 | [@@deriving sexp_of] 32 | 33 | let%expect_test "[Repr.of_obj] Record" = 34 | let record = { a = 20; b = None } |> Obj.repr |> Repr.of_obj in 35 | print_s [%message (record : Repr.t)]; 36 | [%expect 37 | {| 38 | (record ( 39 | Block 40 | (header 2048) 41 | (data ( 42 | (Int 41) 43 | (Int 1))))) |}]; 44 | let record = { a = 64; b = Some { a = 12; b = None } } |> Obj.repr |> Repr.of_obj in 45 | print_s [%message (record : Repr.t)]; 46 | [%expect 47 | {| 48 | (record ( 49 | Block 50 | (header 2048) 51 | (data ( 52 | (Int 129) 53 | (Block 54 | (header 1024) 55 | (data (( 56 | Block 57 | (header 2048) 58 | (data ( 59 | (Int 25) 60 | (Int 1))))))))))) |}] 61 | ;; 62 | 63 | let roundtrip x = x |> Obj.repr |> Repr.of_obj |> Repr.to_obj |> Obj.magic 64 | 65 | let%expect_test "Rountrip via [Repr.t], int" = 66 | let zero = roundtrip 0 in 67 | let one = roundtrip 1 in 68 | let two = roundtrip 2 in 69 | print_s [%message (zero : int) (one : int) (two : int)]; 70 | [%expect {| 71 | ((zero 0) 72 | (one 1) 73 | (two 2)) |}] 74 | ;; 75 | 76 | let%expect_test "Roundtrip via [Repr.t], string" = 77 | let string = roundtrip "hello world" in 78 | print_s [%message (string : string)]; 79 | [%expect {| (string "hello world") |}] 80 | ;; 81 | 82 | let%expect_test "Roundtrip via [Repr.t], record " = 83 | let record = roundtrip { a = 20; b = None } in 84 | print_s [%message (record : x)]; 85 | [%expect 86 | {| 87 | (record ((a 20) (b ()))) |}]; 88 | let record = roundtrip { a = 64; b = Some { a = 12; b = None } } in 89 | print_s [%message (record : x)]; 90 | [%expect {| (record ((a 64) (b (((a 12) (b ())))))) |}] 91 | ;; 92 | -------------------------------------------------------------------------------- /test/lib/test_repr.mli: -------------------------------------------------------------------------------- 1 | (* deliberately empty *) 2 | -------------------------------------------------------------------------------- /test/lib/test_show_instructions.mli: -------------------------------------------------------------------------------- 1 | (* deliberately empty *) 2 | -------------------------------------------------------------------------------- /zinc.md: -------------------------------------------------------------------------------- 1 | Notes on the ZINC instruction set 2 | ================================= 3 | 4 | ACC[n]/PUSH/PUSHACC[n] 5 | 6 | 7 | --------------------------------------------------------------------------------