source: Deliverables/D2.2/8051-indexed-labels-branch/src/ASM/ASMInterpret.ml @ 1357

Last change on this file since 1357 was 1357, checked in by tranquil, 9 years ago
  • changed implementation of constant indexings with extensible arrays
  • work on ASM completed
  • next: optimizations!
File size: 81.1 KB
Line 
1open BitVectors;;
2open Physical;;
3open ASM;;
4open IntelHex;;
5open Util;;
6open Parser;;
7
8exception Fetch_exception of string;;
9exception CodeTooLarge;;
10exception Halt;;
11
12type time = int;;
13type line = [ `P1 of byte
14            | `P3 of byte
15            | `SerialBuff of [ `Eight of byte | `Nine of BitVectors.bit * byte ]];;
16
17let string_of_line =
18  function
19  `P1 b ->
20    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
21      "P1 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
22      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
23    | `P3 b ->
24      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
25        "P2 OUTPUT: " ^ hex_string_of_vect b ^ "\n" ^
26        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
27    | `SerialBuff (`Eight b) ->
28      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
29        "SERIAL 8b OUTPUT: " ^ string_of_vect b ^ "\n" ^
30        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
31    | `SerialBuff (`Nine (b, b')) ->
32      "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
33        "SERIAL 9b OUTPUT: " ^
34        (let i = int_of_vect b' in
35         if b then
36           string_of_int (128 + i)
37         else
38           string_of_int i) ^
39        "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
40
41(* In:  reception time, line of input, new continuation,
42   Out: transmission time, output line, expected duration until reply,
43        new continuation.
44*)
45
46type epsilon = int
47
48type continuation =
49  [`In of time * line * epsilon * continuation] option *
50    [`Out of (time -> line -> time * continuation)]
51
52let rec debug_continuation =
53  (Some (`In (1, (`SerialBuff (`Eight (vect_of_int 5 `Eight))), 0, debug_continuation))), `Out (
54    fun time line ->
55      (* let _ = prerr_endline <*> string_of_line $ line in *)
56      (time + 1),debug_continuation)
57   
58(* no differentiation between internal and external code memory *)
59type status =
60{
61  (* Memory *)
62  code_memory: Physical.WordMap.map;        (* can be reduced *)
63  low_internal_ram: Byte7Map.map;
64  high_internal_ram: Byte7Map.map;
65  external_ram: Physical.WordMap.map;
66
67  (* Program counter *)
68  pc: word;
69
70  (* SFRs *)
71  sp: byte;
72  dpl: byte;
73  dph: byte;
74  pcon: byte;
75  tcon: byte;
76  tmod: byte;
77  tl0: byte;
78  tl1: byte;
79  th0: byte;
80  th1: byte;
81  p1: byte;
82  scon: byte;
83  sbuf: byte;
84  ie: byte;
85  p3: byte;
86  ip: byte;
87  psw: byte;
88  acc: byte;
89  b: byte;
90  t2con: byte;   (* 8052 only *)
91  rcap2l: byte;  (* 8052 only *)
92  rcap2h: byte;  (* 8052 only *)
93  tl2: byte;     (* 8052 only *)
94  th2: byte;     (* 8052 only *)
95
96  (* Latches for the output lines *)
97  p1_latch: byte;
98  p3_latch: byte;
99
100  (* Fields for tracking the state of the processor. *)
101 
102  (* IO specific *)
103  previous_p1_val: bool;
104  previous_p3_val: bool;
105
106  serial_epsilon_out: epsilon option;
107  serial_epsilon_in: epsilon option;
108
109  io_epsilon: epsilon;
110
111  serial_v_in: [`Eight of byte | `Nine of (BitVectors.bit * byte) ] option;
112  serial_v_out: [`Eight of byte | `Nine of (BitVectors.bit * byte) ] option;
113
114  serial_k_out: continuation option;
115
116  io: continuation;
117  expected_out_time: [ `None | `Now | `At of time ];
118
119  (* Timer and clock specific *)
120  clock: time;
121  timer0: word;
122  timer1: word;
123  timer2: word;  (* can be missing *)
124
125  esi_running: bool;
126  t0i_running: bool;
127  t1i_running: bool;
128  e0i_running: bool;
129  e1i_running: bool;
130  es_running: bool;
131
132  exit_addr   : BitVectors.word;
133       
134(*
135        ind_0s      : int BitVectors.WordMap.t;
136  ind_incs    : int BitVectors.WordMap.t;
137  cost_labels : CostLabel.t BitVectors.WordMap.t
138*)     
139}
140
141(* Try to understand what DEC really does!!! *)
142(* Try to understand I/O *)
143let get_sfr status addr from_latch =
144  match int_of_vect addr with
145    (* I/O and timer ports *)
146      0x80 -> assert false (* P0 not modeled *)
147    | 0x90 ->
148      if from_latch then
149        status.p1_latch
150      else status.p1
151    | 0xA0 -> assert false (* P2 not modeled *)
152    | 0xB0 ->
153      if from_latch then
154        status.p3_latch
155      else status.p3
156    | 0x99 -> status.sbuf
157    | 0x8A -> status.tl0
158    | 0x8B -> status.tl1
159    | 0x8C -> status.th0
160    | 0x8D -> status.th1
161    | 0xC8 -> status.t2con
162    | 0xCA -> status.rcap2l
163    | 0xCB -> status.rcap2h
164    | 0xCC -> status.tl2
165    | 0xCD -> status.th2
166
167  (* control ports *)
168    | 0x87 -> status.pcon
169    | 0x88 -> status.tcon
170    | 0x89 -> status.tmod
171    | 0x98 -> status.scon
172    | 0xA8 -> status.ie
173    | 0xB8 -> status.ip
174     
175  (* registers *)
176    | 0x81 -> status.sp
177    | 0x82 -> status.dpl
178    | 0x83 -> status.dph
179    | 0xD0 -> status.psw
180    | 0xE0 -> status.acc
181    | 0xF0 -> status.b
182    | _ -> assert false
183;;
184
185(* Try to understand I/O *)
186let set_sfr status addr v =
187  match int_of_vect addr with
188    (* I/O and timer ports *)
189      0x80 -> assert false (* P0 not modeled *)
190    | 0x90 -> { status with p1 = v; p1_latch = v }
191    | 0xA0 -> assert false (* P2 not modeled *)
192    | 0xB0 -> { status with p3 = v; p3_latch = v }
193    | 0x99 ->
194      if status.expected_out_time = `None then
195        { status with sbuf = v; expected_out_time = `Now }
196      else
197        (* a real assert false: trying to initiate a transmission whilst one is still active *)
198        assert false
199    | 0x8A -> { status with tl0 = v }
200    | 0x8B -> { status with tl1 = v }
201    | 0x8C -> { status with th0 = v }
202    | 0x8D -> { status with th1 = v }
203    | 0xC8 -> { status with t2con = v }
204    | 0xCA -> { status with rcap2l = v }
205    | 0xCB -> { status with rcap2h = v }
206    | 0xCD -> { status with tl2 = v }
207    | 0xCE -> { status with th2 = v }
208
209    (* control ports *)
210    | 0x87 -> { status with pcon = v }
211    | 0x88 -> { status with tcon = v }
212    | 0x89 -> { status with tmod = v }
213    | 0x98 -> { status with scon = v }
214    | 0xA8 -> { status with ie = v }
215    | 0xB8 -> { status with ip = v }
216     
217    (* registers *)
218    | 0x81 -> { status with sp = v }
219    | 0x82 -> { status with dpl = v }
220    | 0x83 -> { status with dph = v }
221    | 0xD0 -> { status with psw = v }
222    | 0xE0 -> { status with acc = v }
223    | 0xF0 -> { status with b = v }
224    | _ -> assert false
225;;
226
227let initialize = {
228  code_memory = Physical.WordMap.empty;
229  low_internal_ram = Byte7Map.empty;
230  high_internal_ram = Byte7Map.empty;
231  external_ram = Physical.WordMap.empty;
232 
233  pc = zero `Sixteen;
234 
235  sp = vect_of_int 7 `Eight;
236  dpl = zero `Eight;
237  dph = zero `Eight;
238  pcon = zero `Eight;
239  tcon = zero `Eight;
240  tmod = zero `Eight;
241  tl0 = zero `Eight;
242  tl1 = zero `Eight;
243  th0 = zero `Eight;
244  th1 = zero `Eight;
245  p1 = zero `Eight;
246  p1_latch = zero `Eight;
247  scon = zero `Eight;
248  sbuf = zero `Eight;
249  ie = zero `Eight;
250  p3 = zero `Eight;
251  p3_latch = zero `Eight;
252  ip = zero `Eight;
253  psw = zero `Eight;
254  acc = zero `Eight;
255  b = zero `Eight;
256  t2con = zero `Eight;
257  rcap2l = zero `Eight;
258  rcap2h = zero `Eight;
259  tl2 = zero `Eight;
260  th2 = zero `Eight;
261
262  previous_p1_val = false;
263  previous_p3_val = false;
264
265  serial_v_in = None;
266  serial_v_out = None;
267  serial_epsilon_in = None;
268  serial_epsilon_out = None;
269  serial_k_out = None;
270
271  io_epsilon = 5;
272
273  clock = 0;
274  timer0 = zero `Sixteen;
275  timer1 = zero `Sixteen;
276  timer2 = zero `Sixteen;
277
278  expected_out_time = `None;
279
280  io = debug_continuation; (* a real assert false: unprepared for i/o *)
281
282  (* Initially no interrupts are executing *)
283  esi_running = false;
284  t0i_running = false;
285  t1i_running = false;
286  e0i_running = false;
287  e1i_running = false;
288  es_running = false;
289
290  exit_addr = BitVectors.zero `Sixteen;
291(*
292  ind_0s = BitVectors.WordMap.empty;
293  ind_incs = BitVectors.WordMap.empty;
294  cost_labels = BitVectors.WordMap.empty
295*)
296}
297
298let get_cy_flag status =
299  let (cy,_,_,_),(_,_,_,_) = bits_of_byte status.psw in cy
300let get_ac_flag status =
301  let (_,ac,_,_),(_,_,_,_) = bits_of_byte status.psw in ac
302let get_fo_flag status =
303  let (_,_,fo,_),(_,_,_,_) = bits_of_byte status.psw in fo
304let get_rs1_flag status =
305  let (_,_,_,rs1),(_,_,_,_) = bits_of_byte status.psw in rs1
306let get_rs0_flag status =
307  let (_,_,_,_),(rs0,_,_,_) = bits_of_byte status.psw in rs0
308let get_ov_flag status =
309  let (_,_,_,_),(_,ov,_,_) = bits_of_byte status.psw in ov
310let get_ud_flag status =
311  let (_,_,_,_),(_,_,ud,_) = bits_of_byte status.psw in ud
312let get_p_flag status =
313  let (_,_,_,_),(_,_,_,p) = bits_of_byte status.psw in p
314
315let get_address_of_register status (b1,b2,b3) =
316  let bu,_bl = from_byte status.psw in
317  let (_,_,rs1,rs0) = from_nibble bu in
318  let base =
319    match rs1,rs0 with
320        false,false -> 0x00
321      | false,true  -> 0x08
322      | true,false  -> 0x10
323      | true,true   -> 0x18
324  in
325  vect_of_int (base + int_of_vect (mk_nibble false b1 b2 b3)) `Seven
326;;
327
328let get_register status reg =
329  let addr = get_address_of_register status reg in
330  Byte7Map.find addr status.low_internal_ram
331;;
332
333let string_of_status status =   
334  let acc_str = (string_of_int <*> int_of_vect $ status.acc) ^ " (" ^ string_of_vect status.acc ^ ")" in
335  let b_str   = (string_of_int <*> int_of_vect $ status.b) ^ " (" ^ string_of_vect status.b ^ ")" in
336  let psw_str = (string_of_int <*> int_of_vect $ status.psw) ^ " (" ^ string_of_vect status.psw ^ ")" in
337  let sp_str  = (string_of_int <*> int_of_vect $ status.sp) ^ " (" ^ string_of_vect status.sp ^ ")" in
338  let ip_str  = (string_of_int <*> int_of_vect $ status.ip) ^ " (" ^ string_of_vect status.ip ^ ")" in
339  let pc_str  = (string_of_int <*> int_of_vect $ status.pc) ^ " (" ^ string_of_vect status.pc ^ ")" in
340  let dpl_str = (string_of_int <*> int_of_vect $ status.dpl) ^ " (" ^ string_of_vect status.dpl ^ ")" in
341  let dph_str = (string_of_int <*> int_of_vect $ status.dph) ^ " (" ^ string_of_vect status.dph ^ ")" in
342  let scn_str = (string_of_int <*> int_of_vect $ status.scon) ^ " (" ^ string_of_vect status.scon ^ ")" in
343  let sbf_str = (string_of_int <*> int_of_vect $ status.sbuf) ^ " (" ^ string_of_vect status.sbuf ^ ")" in
344  let tcn_str = (string_of_int <*> int_of_vect $ status.tcon) ^ " (" ^ string_of_vect status.tcon ^ ")" in
345  let tmd_str = (string_of_int <*> int_of_vect $ status.tmod) ^ " (" ^ string_of_vect status.tmod ^ ")" in
346  let r0_str  = (string_of_int <*> int_of_vect $ get_register status (false, false, false)) ^ " (" ^ (string_of_vect $ get_register status (false, false, false)) ^ ")" in
347  let r1_str  = (string_of_int <*> int_of_vect $ get_register status (false, false, true)) ^ " (" ^ (string_of_vect $ get_register status (false, false, true)) ^ ")" in
348  let r2_str  = (string_of_int <*> int_of_vect $ get_register status (false, true, false)) ^ " (" ^ (string_of_vect $ get_register status (false, true, false)) ^ ")" in
349  let r3_str  = (string_of_int <*> int_of_vect $ get_register status (false, true, true)) ^ " (" ^ (string_of_vect $ get_register status (false, true, true)) ^ ")" in
350  let r4_str  = (string_of_int <*> int_of_vect $ get_register status (true, false, false)) ^ " (" ^ (string_of_vect $ get_register status (true, false, false)) ^ ")" in
351  let r5_str  = (string_of_int <*> int_of_vect $ get_register status (true, false, true)) ^ " (" ^ (string_of_vect $ get_register status (true, false, true)) ^ ")" in
352  let r6_str  = (string_of_int <*> int_of_vect $ get_register status (true, true, false)) ^ " (" ^ (string_of_vect $ get_register status (true, true, false)) ^ ")" in
353  let r7_str  = (string_of_int <*> int_of_vect $ get_register status (true, true, true)) ^ " (" ^ (string_of_vect $ get_register status (true, true, true)) ^ ")" in
354    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
355    " Processor status:                               \n" ^
356    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n" ^
357    "   ACC : " ^ acc_str ^ "\n"                          ^
358    "   B   : " ^ b_str   ^ "\n"                          ^
359    "   PSW : " ^ psw_str ^ "\n"                          ^
360    "    with flags set as                            \n" ^
361    "     CY  : " ^ (string_of_bool <*> get_cy_flag $ status) ^ "\n" ^
362    "     AC  : " ^ (string_of_bool <*> get_ac_flag $ status) ^ "\n" ^
363    "     FO  : " ^ (string_of_bool <*> get_fo_flag $ status) ^ "\n" ^
364    "     RS1 : " ^ (string_of_bool <*> get_rs1_flag $ status) ^ "\n" ^
365    "     RS0 : " ^ (string_of_bool <*> get_rs0_flag $ status) ^ "\n" ^
366    "     OV  : " ^ (string_of_bool <*> get_ov_flag $ status) ^ "\n" ^
367    "     UD  : " ^ (string_of_bool <*> get_ud_flag $ status) ^ "\n" ^
368    "     P   : " ^ (string_of_bool <*> get_p_flag $ status) ^ "\n" ^
369    "   SP  : " ^ sp_str  ^ "\n"                          ^
370    "   IP  : " ^ ip_str  ^ "\n"                          ^
371    "   PC  : " ^ pc_str  ^ "\n"                          ^
372    "   DPL : " ^ dpl_str ^ "\n"                          ^
373    "   DPH : " ^ dph_str ^ "\n"                          ^
374    "   SCON: " ^ scn_str ^ "\n"                          ^
375    "   SBUF: " ^ sbf_str ^ "\n"                          ^
376    "   TMOD: " ^ tmd_str ^ "\n"                          ^
377    "   TCON: " ^ tcn_str ^ "\n"                          ^
378    "   Registers:                                    \n" ^
379    "    R0 : " ^ r0_str  ^ "\n"                          ^
380    "    R1 : " ^ r1_str  ^ "\n"                          ^
381    "    R2 : " ^ r2_str  ^ "\n"                          ^
382    "    R3 : " ^ r3_str  ^ "\n"                          ^
383    "    R4 : " ^ r4_str  ^ "\n"                          ^
384    "    R5 : " ^ r5_str  ^ "\n"                          ^
385    "    R6 : " ^ r6_str  ^ "\n"                          ^
386    "    R7 : " ^ r7_str  ^ "\n"                          ^
387    "-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n"
388
389(* timings taken from SIEMENS *)
390
391let fetch pmem pc =
392  let next pc =
393    let _carry, res = half_add pc (vect_of_int 1 `Sixteen) in
394    res, Physical.WordMap.find pc pmem
395  in
396  let pc,instr = next pc in
397  let un, ln = from_byte instr in
398  let bits = (from_nibble un, from_nibble ln) in
399  match bits with
400      (a10,a9,a8,true),(false,false,false,true) ->
401        let pc,b1 = next pc in
402        `ACALL (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
403    | (false,false,true,false),(true,r1,r2,r3) ->
404      `ADD (`A,`REG (r1,r2,r3)), pc, 1
405    | (false,false,true,false),(false,true,false,true) ->
406      let pc,b1 = next pc in
407      `ADD (`A,`DIRECT b1), pc, 1
408    | (false,false,true,false),(false,true,true,i1) ->
409      `ADD (`A,`INDIRECT i1), pc, 1
410    | (false,false,true,false),(false,true,false,false) ->
411      let pc,b1 = next pc in
412      `ADD (`A,`DATA b1), pc, 1
413    | (false,false,true,true),(true,r1,r2,r3) ->
414      `ADDC (`A,`REG (r1,r2,r3)), pc, 1
415    | (false,false,true,true),(false,true,false,true) ->
416      let pc,b1 = next pc in
417      `ADDC (`A,`DIRECT b1), pc, 1
418    | (false,false,true,true),(false,true,true,i1) ->
419      `ADDC (`A,`INDIRECT i1), pc, 1
420    | (false,false,true,true),(false,true,false,false) ->
421      let pc,b1 = next pc in
422      `ADDC (`A,`DATA b1), pc, 1
423    | (a10,a9,a8,false),(false,false,false,true) ->
424      let pc,b1 = next pc in
425      `AJMP (`ADDR11 (mk_word11 a10 a9 a8 b1)), pc, 2
426    | (false,true,false,true),(true,r1,r2,r3) ->
427      `ANL (`U1 (`A, `REG (r1,r2,r3))), pc, 1
428    | (false,true,false,true),(false,true,false,true) ->
429      let pc,b1 = next pc in
430      `ANL (`U1 (`A, `DIRECT b1)), pc, 1
431    | (false,true,false,true),(false,true,true,i1) ->
432      `ANL (`U1 (`A, `INDIRECT i1)), pc, 1
433    | (false,true,false,true),(false,true,false,false) ->
434      let pc,b1 = next pc in
435      `ANL (`U1 (`A, `DATA b1)), pc, 1
436    | (false,true,false,true),(false,false,true,false) ->
437      let pc,b1 = next pc in
438      `ANL (`U2 (`DIRECT b1,`A)), pc, 1
439    | (false,true,false,true),(false,false,true,true) ->
440      let pc,b1 = next pc in
441      let pc,b2 = next pc in
442      `ANL (`U2 (`DIRECT b1,`DATA b2)), pc, 2
443    | (true,false,false,false),(false,false,true,false) ->
444      let pc,b1 = next pc in
445      `ANL (`U3 (`C,`BIT b1)), pc, 2
446    | (true,false,true,true),(false,false,false,false) ->
447      let pc,b1 = next pc in
448      `ANL (`U3 (`C,`NBIT b1)), pc, 2
449    | (true,false,true,true),(false,true,false,true) ->
450      let pc,b1 = next pc in
451      let pc,b2 = next pc in
452      `CJNE (`U1 (`A, `DIRECT b1), `REL b2), pc, 2
453    | (true,false,true,true),(false,true,false,false) ->
454      let pc,b1 = next pc in
455      let pc,b2 = next pc in
456      `CJNE (`U1 (`A, `DATA b1), `REL b2), pc, 2
457    | (true,false,true,true),(true,r1,r2,r3) ->
458      let pc,b1 = next pc in
459      let pc,b2 = next pc in
460      `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2), pc, 2
461    | (true,false,true,true),(false,true,true,i1) ->
462      let pc,b1 = next pc in
463      let pc,b2 = next pc in
464      `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2), pc, 2
465    | (true,true,true,false),(false,true,false,false) ->
466      `CLR `A, pc, 1
467    | (true,true,false,false),(false,false,true,true) ->
468      `CLR `C, pc, 1
469    | (true,true,false,false),(false,false,true,false) ->
470      let pc,b1 = next pc in
471      `CLR (`BIT b1), pc, 1
472    | (true,true,true,true),(false,true,false,false) ->
473      `CPL `A, pc, 1
474    | (true,false,true,true),(false,false,true,true) ->
475      `CPL `C, pc, 1
476    | (true,false,true,true),(false,false,true,false) ->
477      let pc,b1 = next pc in
478      `CPL (`BIT b1), pc, 1
479    | (true,true,false,true),(false,true,false,false) ->
480      `DA `A, pc, 1
481    | (false,false,false,true),(false,true,false,false) ->
482      `DEC `A, pc, 1
483    | (false,false,false,true),(true,r1,r2,r3) ->
484      `DEC (`REG(r1,r2,r3)), pc, 1
485    | (false,false,false,true),(false,true,false,true) ->
486      let pc,b1 = next pc in
487      `DEC (`DIRECT b1), pc, 1
488    | (false,false,false,true),(false,true,true,i1) ->
489      `DEC (`INDIRECT i1), pc, 1
490    | (true,false,false,false),(false,true,false,false) ->
491      `DIV (`A, `B), pc, 4
492    | (true,true,false,true),(true,r1,r2,r3) ->
493      let pc,b1 = next pc in
494      `DJNZ (`REG(r1,r2,r3), `REL b1), pc, 2
495    | (true,true,false,true),(false,true,false,true) ->
496      let pc,b1 = next pc in
497      let pc,b2 = next pc in
498      `DJNZ (`DIRECT b1, `REL b2), pc, 2
499    | (false,false,false,false),(false,true,false,false) ->
500      `INC `A, pc, 1
501    | (false,false,false,false),(true,r1,r2,r3) ->
502      `INC (`REG(r1,r2,r3)), pc, 1
503    | (false,false,false,false),(false,true,false,true) ->
504      let pc,b1 = next pc in
505      `INC (`DIRECT b1), pc, 1
506    | (false,false,false,false),(false,true,true,i1) ->
507      `INC (`INDIRECT i1), pc, 1
508    | (true,false,true,false),(false,false,true,true) ->
509      `INC `DPTR, pc, 2
510    | (false,false,true,false),(false,false,false,false) ->
511      let pc,b1 = next pc in
512      let pc,b2 = next pc in
513      `JB (`BIT b1, `REL b2), pc, 2
514    | (false,false,false,true),(false,false,false,false) ->
515      let pc,b1 = next pc in
516      let pc,b2 = next pc in
517      `JBC (`BIT b1, `REL b2), pc, 2
518    | (false,true,false,false),(false,false,false,false) ->
519      let pc,b1 = next pc in
520      `JC (`REL b1), pc, 2
521    | (false,true,true,true),(false,false,true,true) ->
522      `JMP `IND_DPTR, pc, 2
523    | (false,false,true,true),(false,false,false,false) ->
524      let pc,b1 = next pc in
525      let pc,b2 = next pc in
526      `JNB (`BIT b1, `REL b2), pc, 2
527    | (false,true,false,true),(false,false,false,false) ->
528      let pc,b1 = next pc in
529      `JNC (`REL b1), pc, 2
530    | (false,true,true,true),(false,false,false,false) ->
531      let pc,b1 = next pc in
532      `JNZ (`REL b1), pc, 2
533    | (false,true,true,false),(false,false,false,false) ->
534      let pc,b1 = next pc in
535      `JZ (`REL b1), pc, 2
536    | (false,false,false,true),(false,false,true,false) ->
537      let pc,b1 = next pc in
538      let pc,b2 = next pc in
539      `LCALL (`ADDR16 (mk_word b1 b2)), pc, 2
540    | (false,false,false,false),(false,false,true,false) ->
541      let pc,b1 = next pc in
542      let pc,b2 = next pc in
543      `LJMP (`ADDR16 (mk_word b1 b2)), pc, 2
544   | (true,true,true,false),(true,r1,r2,r3) ->
545         `MOV (`U1 (`A, `REG(r1,r2,r3))), pc, 1
546   | (true,true,true,false),(false,true,false,true) ->
547       let pc,b1 = next pc in
548         `MOV (`U1 (`A, `DIRECT b1)), pc, 1
549   | (true,true,true,false),(false,true,true,i1) ->
550         `MOV (`U1 (`A, `INDIRECT i1)), pc, 1
551   | (false,true,true,true),(false,true,false,false) ->
552       let pc,b1 = next pc in
553         `MOV (`U1 (`A, `DATA b1)), pc, 1
554   | (true,true,true,true),(true,r1,r2,r3) ->
555         `MOV (`U2 (`REG(r1,r2,r3), `A)), pc, 1
556   | (true,false,true,false),(true,r1,r2,r3) ->
557       let pc,b1 = next pc in
558         `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))), pc, 2
559   | (false,true,true,true),(true,r1,r2,r3) ->
560       let pc,b1 = next pc in
561         `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))), pc, 1
562   | (true,true,true,true),(false,true,false,true) ->
563       let pc,b1 = next pc in
564         `MOV (`U3 (`DIRECT b1, `A)), pc, 1
565   | (true,false,false,false),(true,r1,r2,r3) ->
566       let pc,b1 = next pc in
567         `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))), pc, 2
568   | (true,false,false,false),(false,true,false,true) ->
569       let pc,b1 = next pc in
570       let pc,b2 = next pc in
571         `MOV (`U3 (`DIRECT b1, `DIRECT b2)), pc, 2
572   | (true,false,false,false),(false,true,true,i1) ->
573       let pc,b1 = next pc in
574         `MOV (`U3 (`DIRECT b1, `INDIRECT i1)), pc, 2
575   | (false,true,true,true),(false,true,false,true) ->
576       let pc,b1 = next pc in
577       let pc,b2 = next pc in
578         `MOV (`U3 (`DIRECT b1, `DATA b2)), pc, 3
579   | (true,true,true,true),(false,true,true,i1) ->
580         `MOV (`U2 (`INDIRECT i1, `A)), pc, 1
581   | (true,false,true,false),(false,true,true,i1) ->
582       let pc,b1 = next pc in
583         `MOV (`U2 (`INDIRECT i1, `DIRECT b1)), pc, 2
584   | (false,true,true,true),(false,true,true,i1) ->
585       let pc,b1 = next pc in
586         `MOV (`U2 (`INDIRECT i1, `DATA b1)), pc, 1
587   | (true,false,true,false),(false,false,true,false) ->
588       let pc,b1 = next pc in
589         `MOV (`U5 (`C, `BIT b1)), pc, 1
590   | (true,false,false,true),(false,false,true,false) ->
591       let pc,b1 = next pc in
592         `MOV (`U6 (`BIT b1, `C)), pc, 2
593   | (true,false,false,true),(false,false,false,false) ->
594       let pc,b1 = next pc in
595       let pc,b2 = next pc in
596         `MOV (`U4 (`DPTR, `DATA16(mk_word b1 b2))), pc, 2
597   | (true,false,false,true),(false,false,true,true) ->
598         `MOVC (`A, `A_DPTR), pc, 2
599   | (true,false,false,false),(false,false,true,true) ->
600         `MOVC (`A, `A_PC), pc, 2
601   | (true,true,true,false),(false,false,true,i1) ->
602         `MOVX (`U1 (`A, `EXT_INDIRECT i1)), pc, 2
603   | (true,true,true,false),(false,false,false,false) ->
604         `MOVX (`U1 (`A, `EXT_IND_DPTR)), pc, 2
605   | (true,true,true,true),(false,false,true,i1) ->
606         `MOVX (`U2 (`EXT_INDIRECT i1, `A)), pc, 2
607   | (true,true,true,true),(false,false,false,false) ->
608         `MOVX (`U2 (`EXT_IND_DPTR, `A)), pc, 2
609   | (true,false,true,false),(false,true,false,false) ->
610         `MUL(`A, `B), pc, 4
611   | (false,false,false,false),(false,false,false,false) ->
612         `NOP, pc, 1
613   | (false,true,false,false),(true,r1,r2,r3) ->
614         `ORL (`U1(`A, `REG(r1,r2,r3))), pc, 1
615   | (false,true,false,false),(false,true,false,true) ->
616       let pc,b1 = next pc in
617         `ORL (`U1(`A, `DIRECT b1)), pc, 1
618   | (false,true,false,false),(false,true,true,i1) ->
619         `ORL (`U1(`A, `INDIRECT i1)), pc, 1
620   | (false,true,false,false),(false,true,false,false) ->
621       let pc,b1 = next pc in
622         `ORL (`U1(`A, `DATA b1)), pc, 1
623   | (false,true,false,false),(false,false,true,false) ->
624       let pc,b1 = next pc in
625         `ORL (`U2(`DIRECT b1, `A)), pc, 1
626   | (false,true,false,false),(false,false,true,true) ->
627       let pc,b1 = next pc in
628       let pc,b2 = next pc in
629         `ORL (`U2 (`DIRECT b1, `DATA b2)), pc, 2
630   | (false,true,true,true),(false,false,true,false) ->
631       let pc,b1 = next pc in
632         `ORL (`U3 (`C, `BIT b1)), pc, 2
633   | (true,false,true,false),(false,false,false,false) ->
634       let pc,b1 = next pc in
635         `ORL (`U3 (`C, `NBIT b1)), pc, 2
636   | (true,true,false,true),(false,false,false,false) ->
637       let pc,b1 = next pc in
638         `POP (`DIRECT b1), pc, 2
639   | (true,true,false,false),(false,false,false,false) ->
640       let pc,b1 = next pc in
641         `PUSH (`DIRECT b1), pc, 2
642   | (false,false,true,false),(false,false,true,false) ->
643         `RET, pc, 2
644   | (false,false,true,true),(false,false,true,false) ->
645         `RETI, pc, 2
646   | (false,false,true,false),(false,false,true,true) ->
647         `RL `A, pc, 1
648   | (false,false,true,true),(false,false,true,true) ->
649         `RLC `A, pc, 1
650   | (false,false,false,false),(false,false,true,true) ->
651         `RR `A, pc, 1
652   | (false,false,false,true),(false,false,true,true) ->
653         `RRC `A, pc, 1
654   | (true,true,false,true),(false,false,true,true) ->
655         `SETB `C, pc, 1
656   | (true,true,false,true),(false,false,true,false) ->
657       let pc,b1 = next pc in
658         `SETB (`BIT b1), pc, 1
659   | (true,false,false,false),(false,false,false,false) ->
660       let pc,b1 = next pc in
661         `SJMP (`REL b1), pc, 2
662   | (true,false,false,true),(true,r1,r2,r3) ->
663       `SUBB (`A, `REG(r1,r2,r3)), pc, 1
664   | (true,false,false,true),(false,true,false,true) ->
665       let pc,b1 = next pc in
666         `SUBB (`A, `DIRECT b1), pc, 1
667   | (true,false,false,true),(false,true,true,i1) ->
668         `SUBB (`A, `INDIRECT i1), pc, 1
669   | (true,false,false,true),(false,true,false,false) ->
670       let pc,b1 = next pc in
671         `SUBB (`A, `DATA b1), pc, 1
672   | (true,true,false,false),(false,true,false,false) ->
673         `SWAP `A, pc, 1
674   | (true,true,false,false),(true,r1,r2,r3) ->
675         `XCH (`A, `REG(r1,r2,r3)), pc, 1
676   | (true,true,false,false),(false,true,false,true) ->
677       let pc,b1 = next pc in
678         `XCH (`A, `DIRECT b1), pc, 1
679   | (true,true,false,false),(false,true,true,i1) ->
680         `XCH (`A, `INDIRECT i1), pc, 1
681   | (true,true,false,true),(false,true,true,i1) ->
682         `XCHD(`A, `INDIRECT i1), pc, 1
683   | (false,true,true,false),(true,r1,r2,r3) ->
684         `XRL(`U1(`A, `REG(r1,r2,r3))), pc, 1
685   | (false,true,true,false),(false,true,false,true) ->
686       let pc,b1 = next pc in
687         `XRL(`U1(`A, `DIRECT b1)), pc, 1
688   | (false,true,true,false),(false,true,true,i1) ->
689         `XRL(`U1(`A, `INDIRECT i1)), pc, 1
690   | (false,true,true,false),(false,true,false,false) ->
691       let pc,b1 = next pc in
692         `XRL(`U1(`A, `DATA b1)), pc, 1
693   | (false,true,true,false),(false,false,true,false) ->
694       let pc,b1 = next pc in
695         `XRL(`U2(`DIRECT b1, `A)), pc, 1
696   | (false,true,true,false),(false,false,true,true) ->
697       let pc,b1 = next pc in
698       let pc,b2 = next pc in
699         `XRL(`U2(`DIRECT b1, `DATA b2)), pc, 2
700   | (true,false,true,false),(false,true,false,true) ->
701       (* undefined opcode *) assert false
702;;
703
704let assembly1 =
705 function
706    `ACALL (`ADDR11 w) ->
707      let (a10,a9,a8,b1) = from_word11 w in
708        [mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
709  | `ADD (`A,`REG (r1,r2,r3)) ->
710     [mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
711  | `ADD (`A, `DIRECT b1) ->
712     [mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
713  | `ADD (`A, `INDIRECT i1) ->
714     [mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
715  | `ADD (`A, `DATA b1) ->
716     [mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
717  | `ADDC (`A, `REG(r1,r2,r3)) ->
718     [mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
719  | `ADDC (`A, `DIRECT b1) ->
720     [mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
721  | `ADDC (`A,`INDIRECT i1) ->
722     [mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
723  | `ADDC (`A,`DATA b1) ->
724     [mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
725  | `AJMP (`ADDR11 w) ->
726     let (a10,a9,a8,b1) = from_word11 w in
727       [mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true)); b1]
728  | `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
729     [mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
730  | `ANL (`U1 (`A, `DIRECT b1)) ->
731     [mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
732  | `ANL (`U1 (`A, `INDIRECT i1)) ->
733     [mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
734  | `ANL (`U1 (`A, `DATA b1)) ->
735     [mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
736  | `ANL (`U2 (`DIRECT b1,`A)) ->
737     [mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
738  | `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
739     [mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
740  | `ANL (`U3 (`C,`BIT b1)) ->
741     [mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
742  | `ANL (`U3 (`C,`NBIT b1)) ->
743    [mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
744  | `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
745    [mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
746  | `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
747    [mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
748  | `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
749    [mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
750  | `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
751    [mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
752  | `CLR `A ->
753    [mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
754  | `CLR `C ->
755    [mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
756  | `CLR (`BIT b1) ->
757    [mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
758  | `CPL `A ->
759    [mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
760  | `CPL `C ->
761    [mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
762  | `CPL (`BIT b1) ->
763    [mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
764  | `DA `A ->
765    [mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
766  | `DEC `A ->
767    [mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
768  | `DEC (`REG(r1,r2,r3)) ->
769    [mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
770  | `DEC (`DIRECT b1) ->
771    [mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
772  | `DEC (`INDIRECT i1) ->
773    [mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
774  | `DIV (`A, `B) ->
775    [mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
776  | `DJNZ (`REG(r1,r2,r3), `REL b1) ->
777    [mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
778  | `DJNZ (`DIRECT b1, `REL b2) ->
779    [mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
780  | `INC `A ->
781    [mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
782  | `INC (`REG(r1,r2,r3)) ->
783    [mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
784  | `INC (`DIRECT b1) ->
785    [mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
786  | `INC (`INDIRECT i1) ->
787    [mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
788  | `INC `DPTR ->
789    [mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
790  | `JB (`BIT b1, `REL b2) ->
791    [mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
792  | `JBC (`BIT b1, `REL b2) ->
793    [mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
794  | `JC (`REL b1) ->
795    [mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
796  | `JMP `IND_DPTR ->
797    [mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
798  | `JNB (`BIT b1, `REL b2) ->
799    [mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
800  | `JNC (`REL b1) ->
801    [mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
802  | `JNZ (`REL b1) ->
803    [mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
804  | `JZ (`REL b1) ->
805    [mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
806  | `LCALL (`ADDR16 w) ->
807      let (b1,b2) = from_word w in
808        [mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
809  | `LJMP (`ADDR16 w) ->
810      let (b1,b2) = from_word w in
811        [mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
812  | `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
813    [mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
814  | `MOV (`U1 (`A, `DIRECT b1)) ->
815    [mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
816  | `MOV (`U1 (`A, `INDIRECT i1)) ->
817    [mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
818  | `MOV (`U1 (`A, `DATA b1)) ->
819    [mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
820  | `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
821    [mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
822  | `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
823    [mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
824  | `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
825    [mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
826  | `MOV (`U3 (`DIRECT b1, `A)) ->
827    [mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
828  | `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
829    [mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
830  | `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
831    [mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
832  | `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
833    [mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
834  | `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
835    [mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
836  | `MOV (`U2 (`INDIRECT i1, `A)) ->
837    [mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
838  | `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
839    [mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
840  | `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
841    [mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
842  | `MOV (`U5 (`C, `BIT b1)) ->
843    [mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
844  | `MOV (`U6 (`BIT b1, `C)) ->
845    [mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
846  | `MOV (`U4 (`DPTR, `DATA16 w)) ->
847    let (b1,b2) = from_word w in
848      [mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
849  | `MOVC (`A, `A_DPTR) ->
850    [mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
851  | `MOVC (`A, `A_PC) ->
852    [mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
853  | `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
854    [mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
855  | `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
856    [mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
857  | `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
858    [mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
859  | `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
860    [mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
861  | `MUL(`A, `B) ->
862    [mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
863  | `NOP ->
864    [mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
865  | `ORL (`U1(`A, `REG(r1,r2,r3))) ->
866    [mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
867  | `ORL (`U1(`A, `DIRECT b1)) ->
868    [mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
869  | `ORL (`U1(`A, `INDIRECT i1)) ->
870    [mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
871  | `ORL (`U1(`A, `DATA b1)) ->
872    [mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
873  | `ORL (`U2(`DIRECT b1, `A)) ->
874    [mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
875  | `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
876    [mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
877  | `ORL (`U3 (`C, `BIT b1)) ->
878    [mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
879  | `ORL (`U3 (`C, `NBIT b1)) ->
880    [mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
881  | `POP (`DIRECT b1) ->
882    [mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
883  | `PUSH (`DIRECT b1) ->
884    [mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
885  | `RET ->
886    [mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
887  | `RETI ->
888    [mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
889  | `RL `A ->
890    [mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
891  | `RLC `A ->
892    [mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
893  | `RR `A ->
894    [mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
895  | `RRC `A ->
896    [mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
897  | `SETB `C ->
898    [mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
899  | `SETB (`BIT b1) ->
900    [mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
901  | `SJMP (`REL b1) ->
902    [mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
903  | `SUBB (`A, `REG(r1,r2,r3)) ->
904    [mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
905  | `SUBB (`A, `DIRECT b1) ->
906    [mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
907  | `SUBB (`A, `INDIRECT i1) ->
908    [mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
909  | `SUBB (`A, `DATA b1) ->
910    [mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
911  | `SWAP `A ->
912    [mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
913  | `XCH (`A, `REG(r1,r2,r3)) ->
914    [mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
915  | `XCH (`A, `DIRECT b1) ->
916    [mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
917  | `XCH (`A, `INDIRECT i1) ->
918    [mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
919  | `XCHD(`A, `INDIRECT i1) ->
920    [mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
921  | `XRL(`U1(`A, `REG(r1,r2,r3))) ->
922    [mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
923  | `XRL(`U1(`A, `DIRECT b1)) ->
924    [mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
925  | `XRL(`U1(`A, `INDIRECT i1)) ->
926    [mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
927  | `XRL(`U1(`A, `DATA b1)) ->
928    [mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
929  | `XRL(`U2(`DIRECT b1, `A)) ->
930    [mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
931  | `XRL(`U2(`DIRECT b1, `DATA b2)) ->
932    [mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
933;;
934
935let load_code_memory = MiscPottier.foldi (fun i mem v -> Physical.WordMap.add (vect_of_int i `Sixteen) v mem) Physical.WordMap.empty
936
937let load_mem mem status = { status with code_memory = mem }
938let load l = load_mem (load_code_memory l)
939
940let assembly_jump addr_of =
941 function
942    `JC a1 -> `JC (addr_of a1)
943  | `JNC a1 -> `JNC (addr_of a1)
944  | `JB (a1,a2) -> `JB (a1,addr_of a2)
945  | `JNB (a1,a2) -> `JNB (a1,addr_of a2)
946  | `JBC (a1,a2) -> `JBC (a1,addr_of a2)
947  | `JZ a1 -> `JZ (addr_of a1)
948  | `JNZ a1 -> `JNZ (addr_of a1)
949  | `CJNE (a1,a2) -> `CJNE (a1,addr_of a2)
950  | `DJNZ (a1,a2) -> `DJNZ (a1,addr_of a2)
951;;
952
953let assembly p =
954 let datalabels,_ =
955  List.fold_left
956   (fun (datalabels,addr) (name,size) ->
957     let addr16 = vect_of_int addr `Sixteen in
958      StringTools.Map.add name addr16 datalabels, addr+size
959   ) (StringTools.Map.empty,0) p.ASM.ppreamble
960 in
961 let pc,exit_addr,labels,inds,incs,costs =
962  List.fold_left
963   (fun (pc,exit_addr,labels,inds,incs,costs) i ->
964     match i with
965        `Label s when s = p.ASM.pexit_label -> pc, pc, StringTools.Map.add s pc labels, inds, incs, costs
966      | `Label s -> pc, exit_addr, StringTools.Map.add s pc labels, inds, incs, costs
967      | `Cost s -> pc, exit_addr, labels, inds, incs, BitVectors.WordMap.add pc s costs
968                        | `Index i -> pc, exit_addr, labels, BitVectors.WordMap.add pc i inds, incs, costs
969      | `Inc i -> pc, exit_addr, labels, inds, BitVectors.WordMap.add pc i incs, costs
970      | `Mov (_,_) -> (snd (half_add pc (vect_of_int 1 `Sixteen))), exit_addr, labels, inds, incs, costs
971      | `Jmp _ 
972      | `Call _ -> (snd (half_add pc (BitVectors.vect_of_int 3 `Sixteen))), exit_addr, labels, inds, incs, costs
973      (*CSC: very stupid: always expand to worst opcode *)
974      | `WithLabel i ->
975        let fake_addr _ = `REL (zero `Eight) in
976        let fake_jump = assembly_jump fake_addr i in
977        let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
978        assert (fake_jump = i');
979        let pc' = snd (half_add pc' (vect_of_int 5 `Sixteen)) in
980          (snd (half_add pc pc'), exit_addr, labels, inds, incs, costs)
981      | #instruction as i ->
982        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
983         assert (i = i');
984         (snd (half_add pc pc'),exit_addr,labels, inds, incs, costs)
985   )
986    (BitVectors.zero `Sixteen,BitVectors.zero `Sixteen,
987     StringTools.Map.empty, BitVectors.WordMap.empty, BitVectors.WordMap.empty,
988                 BitVectors.WordMap.empty) p.ASM.pcode
989 in
990 let code =
991  List.flatten (List.map
992     (function
993        `Label _
994      | `Cost _
995                        | `Index _
996                        | `Inc _ -> []
997      | `WithLabel i ->
998         (* We need to expand a conditional jump to a label to a machine language
999            conditional jump.  Suppose we have:
1000              JC label
1001            This should be expanded to:
1002              JC 2         -- size of a short jump
1003              SJMP 3       -- size of a long jump
1004              LJMP offset  -- offset = position of label in code
1005            And, for ever label appearing after the location of the jump in code
1006            memory, we must increment by 5, as we added two new instructions. *)
1007        let to_ljmp = `REL (vect_of_int 2 `Eight) in
1008        let offset = 5 in
1009         let jmp_address, translated_jump =
1010           match i with
1011             `JC (`Label a) ->
1012               let address = StringTools.Map.find a labels in
1013               let reconstructed = `JC to_ljmp in
1014                 address, reconstructed
1015           | `JNC (`Label a) ->
1016               let address = StringTools.Map.find a labels in
1017               let reconstructed = `JNC to_ljmp in
1018                 address, reconstructed
1019           | `JB (b, `Label a) ->
1020               let address = StringTools.Map.find a labels in
1021               let reconstructed = `JB (b, to_ljmp) in
1022                 address, reconstructed
1023           | `JNB (b, `Label a) ->
1024               let address = StringTools.Map.find a labels in
1025               let reconstructed = `JNB (b, to_ljmp) in
1026                 address, reconstructed
1027           | `JBC (b, `Label a) ->
1028               let address = StringTools.Map.find a labels in
1029               let reconstructed = `JBC (b, to_ljmp) in
1030                 address, reconstructed
1031           | `JZ (`Label a) ->
1032               let address = StringTools.Map.find a labels in
1033               let reconstructed = `JZ (to_ljmp) in
1034                 address, reconstructed
1035           | `JNZ (`Label a) ->
1036               let address = StringTools.Map.find a labels in
1037               let reconstructed = `JNZ (to_ljmp) in
1038                 address, reconstructed
1039           | `CJNE (args, `Label a) ->
1040               let address = StringTools.Map.find a labels in
1041               let reconstructed = `CJNE (args, to_ljmp) in
1042                 address, reconstructed
1043           | `DJNZ (args, `Label a) ->
1044               let address = StringTools.Map.find a labels in
1045               let reconstructed = `DJNZ (args, to_ljmp) in
1046                 address, reconstructed
1047         in
1048           let sjmp, jmp = `SJMP (`REL (vect_of_int 3 `Eight)), `LJMP (`ADDR16 jmp_address) in
1049           let translation = [ translated_jump; sjmp; jmp ] in
1050             List.flatten (List.map assembly1 translation)
1051      | `Mov (`DPTR,s) ->
1052          let addrr16 = StringTools.Map.find s datalabels in
1053           assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
1054      | `Jmp s ->
1055          let pc_offset = StringTools.Map.find s labels in
1056            assembly1 (`LJMP (`ADDR16 pc_offset))
1057      | `Call s ->
1058          let pc_offset = StringTools.Map.find s labels in
1059            assembly1 (`LCALL (`ADDR16 pc_offset ))
1060      | #instruction as i -> assembly1 i) p.ASM.pcode) in
1061 { ASM.code = code ; ASM.inds = inds; ASM.incs = incs; ASM.cost_labels = costs ;
1062   ASM.exit_addr = exit_addr ; ASM.has_main = p.ASM.phas_main }
1063;;
1064
1065let set_register status v reg =
1066  let addr = get_address_of_register status reg in
1067    { status with low_internal_ram =
1068        Byte7Map.add addr v status.low_internal_ram }
1069;;
1070
1071let get_arg_8 status from_latch = 
1072 function
1073    `DIRECT addr ->
1074       let n0, n1 = from_byte addr in
1075       (match from_nibble n0 with
1076          (false,r1,r2,r3) ->
1077            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
1078        | _ -> get_sfr status addr from_latch)
1079  | `INDIRECT b ->
1080       let (b1, b2) = from_byte (get_register status (false,false,b)) in
1081         (match (from_nibble b1, b2) with 
1082           (false,r1,r2,r3),b2 ->
1083             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
1084         | (true,r1,r2,r3),b2 ->
1085             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
1086  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
1087  | `A -> status.acc
1088  | `B -> status.b
1089  | `DATA b -> b
1090  | `A_DPTR ->
1091       let dpr = mk_word status.dph status.dpl in
1092       (* CSC: what is the right behaviour in case of overflow?
1093          assert false for now. Try to understand what DEC really does *)
1094       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
1095         Physical.WordMap.find addr status.external_ram
1096  | `A_PC ->
1097       (* CSC: what is the right behaviour in case of overflow?
1098          assert false for now *)
1099       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
1100         Physical.WordMap.find addr status.external_ram
1101  | `EXT_INDIRECT b ->
1102         let addr = get_register status (false,false,b) in
1103           Physical.WordMap.find (mk_word (zero `Eight) addr) status.external_ram
1104  | `EXT_IND_DPTR ->
1105       let dpr = mk_word status.dph status.dpl in
1106         Physical.WordMap.find dpr status.external_ram
1107;;
1108
1109let get_arg_16 _status = function `DATA16 w -> w
1110
1111let get_arg_1 status from_latch =
1112  function
1113    `BIT addr
1114  | `NBIT addr as x ->
1115     let n1, n2 = from_byte addr in
1116     let res =
1117      (match from_nibble n1 with
1118         (false,r1,r2,r3) ->
1119           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1120           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1121             get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1122        | (true,r1,r2,r3) ->
1123            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1124            let div = addr / 8 in
1125            let rem = addr mod 8 in
1126              get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1127    in (match x with `NBIT _ -> not res | _ -> res)
1128  | `C -> get_cy_flag status
1129
1130let set_arg_1 status v =
1131  function
1132    `BIT addr ->
1133      let n1, n2 = from_byte addr in
1134      (match from_nibble n1 with
1135         (false,r1,r2,r3) ->
1136           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1137           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1138           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1139             { status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1140      | (true,r1,r2,r3) ->
1141            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1142            let div = addr / 8 in
1143            let rem = addr mod 8 in
1144            let addr' = vect_of_int ((div * 8) + 128) `Eight in
1145            let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1146            let sfr' = set_bit sfr rem v in
1147              set_sfr status addr' sfr')
1148    | `C ->
1149       let (n1,n2) = from_byte status.psw in
1150       let (_,b2,b3,b4) = from_nibble n1 in
1151         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1152
1153let set_arg_8 status v =
1154  function
1155  `DIRECT addr ->
1156    let (b1, b2) = from_byte addr in
1157    (match from_nibble b1 with
1158        (false,r1,r2,r3) ->
1159          { status with low_internal_ram =
1160              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1161      | _ -> set_sfr status addr v)
1162    | `INDIRECT b ->
1163      let (b1, b2) = from_byte (get_register status (false,false,b)) in
1164      (match (from_nibble b1, b2) with 
1165          (false,r1,r2,r3),n1 ->
1166            { status with low_internal_ram =
1167                Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1168        | (true,r1,r2,r3),n1 ->
1169          { status with high_internal_ram =
1170              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1171    | `REG (b1,b2,b3) ->
1172      set_register status v (b1,b2,b3)
1173    | `A -> { status with acc = v }
1174    | `B -> { status with b = v }
1175    | `EXT_IND_DPTR ->
1176      let dpr = mk_word status.dph status.dpl in
1177      { status with external_ram =
1178          Physical.WordMap.add dpr v status.external_ram }
1179    | `EXT_INDIRECT b ->
1180      let addr = get_register status (false,false,b) in
1181      { status with external_ram =
1182          Physical.WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1183;;
1184
1185let set_arg_16 status wrd =
1186  function
1187  `DPTR ->
1188    let (dh, dl) = from_word wrd in
1189    { status with dph = dh; dpl = dl }
1190     
1191let set_flags status c ac ov =
1192  { status with psw =
1193      let bu,bl = from_byte status.psw in
1194      let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1195      let ac = match ac with None -> oac | Some v -> v in
1196      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1197  }
1198;;
1199
1200let xor b1 b2 =
1201  if b1 = true && b2 = true then
1202    false
1203  else if b1 = false && b2 = false then
1204    false
1205  else true
1206;;
1207
1208let read_at_sp status =
1209  let n1,n2 = from_byte status.sp in
1210  let m,r1,r2,r3 = from_nibble n1 in
1211  Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1212    (if m then status.low_internal_ram else status.high_internal_ram)
1213;;
1214
1215let write_at_sp status v =
1216  let n1,n2 = from_byte status.sp in
1217  match from_nibble n1 with
1218      true,r1,r2,r3 ->
1219        let memory =
1220          Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1221        in
1222        { status with low_internal_ram = memory }
1223    | false,r1,r2,r3 ->
1224      let memory =
1225        Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1226      in
1227      { status with high_internal_ram = memory }
1228;;
1229
1230let timer0 status b1 b2 ticks =
1231  let b = get_bit status.tcon 4 in
1232          (* Timer0 first *)
1233  (match b1,b2 with
1234      true,true ->
1235              (* Archaic 13 bit mode. *)
1236        if b then
1237          let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1238          let res = int_of_vect res in
1239          if res > 31 then
1240            let res = res mod 32 in
1241            let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1242            if ov' then
1243              let b = set_bit status.tcon 7 true in
1244              { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1245            else
1246              { status with th0 = res'; tl0 = vect_of_int res `Eight }
1247          else
1248            { status with tl0 = vect_of_int res `Eight }
1249        else
1250          status
1251    | false,false ->
1252              (* 8 bit split timer mode. *)
1253      let status = 
1254        (if b then
1255            let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1256            if ov then
1257              let b = set_bit status.tcon 5 true in
1258              { status with tcon = b; tl0 = res }
1259            else
1260              { status with tl0 = res }
1261         else
1262            status)
1263      in
1264      if get_bit status.tcon 6 then
1265        let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1266        if ov then
1267          let b = set_bit status.tcon 7 true in
1268          { status with tcon = b; th0 = res }
1269        else
1270          { status with th0 = res }
1271      else
1272        status
1273    | false,true ->
1274             (* 16 bit timer mode. *)
1275      if b then
1276        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1277                if ov then
1278                  let b = set_bit status.tcon 5 true in
1279                  let new_th0,new_tl0 = from_word res in
1280                  { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1281                else
1282                  let new_th0,new_tl0 = from_word res in
1283                  { status with th0 = new_th0; tl0 = new_tl0 }
1284      else
1285        status
1286    | true,false ->
1287              (* 8 bit single timer mode. *)
1288      if b then
1289        let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1290        if ov then
1291          let b = set_bit status.tcon 5 true in
1292          { status with tcon = b; tl0 = status.th0; }
1293        else
1294          { status with tl0 = res }
1295      else
1296        status)
1297   
1298let timer1 status b3 b4 ticks =
1299  let b = get_bit status.tcon 4 in
1300  (match b3,b4 with
1301      true,true ->
1302        (* Archaic 13 bit mode. *)
1303        if b then
1304          let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1305          let res = int_of_vect res in
1306          if res > 31 then
1307            let res = res mod 32 in
1308            let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1309            if ov' then
1310              let b = set_bit status.tcon 7 true in
1311              { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1312            else
1313              { status with th1 = res'; tl0 = vect_of_int res `Eight }
1314          else
1315            { status with tl1 = vect_of_int res `Eight }
1316        else
1317          status
1318    | false,false ->
1319              (* 8 bit split timer mode. *)
1320      let status = 
1321        (if b then
1322            let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1323            if ov then
1324              let b = set_bit status.tcon 5 true in
1325                        { status with tcon = b; tl1 = res }
1326            else
1327              { status with tl1 = res }
1328         else
1329            status)
1330      in
1331      if get_bit status.tcon 6 then
1332        let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1333        if ov then
1334          let b = set_bit status.tcon 7 true in
1335          { status with tcon = b; th1 = res }
1336        else
1337          { status with th1 = res }
1338      else
1339        status
1340    | false,true ->
1341             (* 16 bit timer mode. *)
1342      if b then
1343        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1344        if ov then
1345          let b = set_bit status.tcon 5 true in
1346          let new_th1,new_tl1 = from_word res in
1347          { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1348        else
1349          let new_th1,new_tl1 = from_word res in
1350          { status with th1 = new_th1; tl1 = new_tl1 }
1351      else
1352        status
1353    | true,false ->
1354              (* 8 bit single timer mode. *)
1355      if b then
1356        let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1357        if ov then
1358          let b = set_bit status.tcon 5 true in
1359          { status with tcon = b; tl1 = status.th1; }
1360        else
1361          { status with tl1 = res }
1362      else
1363        status)
1364;;
1365
1366let timers status ticks =
1367  (* DPM: Clock/Timer code follows. *)
1368  match bits_of_byte status.tmod with
1369    | (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1370      let status =
1371        (if g0 then
1372            if get_bit status.p3 2 then
1373              if c0 then
1374                if status.previous_p1_val && not $ get_bit status.p3 4 then
1375                  timer0 status b1 b2 ticks
1376                else
1377                  status
1378              else
1379                timer0 status b1 b2 ticks
1380            else
1381              status
1382         else
1383            timer0 status b1 b2 ticks) in
1384      (* Timer 1 follows. *)
1385      let status =
1386        (if g1 then
1387            if get_bit status.p1 3 then
1388              if c1 then
1389                if status.previous_p3_val && not $ get_bit status.p3 5 then
1390                  timer1 status b3 b4 ticks
1391                else
1392                  status
1393              else
1394                timer1 status b3 b4 ticks
1395            else
1396              status
1397         else
1398            timer1 status b3 b4 ticks) in
1399      (* Timer 2 follows *)
1400      let status =
1401        (let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in
1402          (* Timer2 is enabled *)
1403         if tr2 then
1404            (* Counter/interval mode *)
1405           if ct2 && not cp2 then
1406             let word = mk_word status.th2 status.tl2 in
1407             let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in
1408             if ov then
1409               let new_th2 = status.rcap2h in
1410               let new_tl2 = status.rcap2l in
1411                  (* Overflow flag not set if either of the following flags are set *)
1412               if not rclk && not tclk then
1413                 let b = set_bit status.t2con 7 true in
1414                 { status with t2con = b;
1415                   th2 = new_th2;
1416                   tl2 = new_tl2 }
1417               else
1418                 { status with th2 = new_th2;
1419                   tl2 = new_tl2 }
1420             else
1421                (* Reload also signalled when a 1-0 transition is detected *)
1422               if status.previous_p1_val && not $ get_bit status.p1 1 then
1423                  (* In which case signal reload by setting T2CON.6 *)
1424                 let b = set_bit status.t2con 6 true in
1425                 { status with th2 = status.rcap2h;
1426                   tl2 = status.rcap2l;
1427                   t2con = b }
1428               else
1429                 let new_th2, new_tl2 = from_word res in
1430                 { status with th2 = new_th2;
1431                   tl2 = new_tl2 }
1432            (* Capture mode *)
1433           else if cp2 && exen2 then
1434              (* 1-0 transition detected *)
1435              (* DPM: look at this: is the timer still running throughout? *)
1436             if status.previous_p1_val && not $ get_bit status.p1 1 then
1437               status (* Implement clock here *)
1438             else
1439               status (* Implement clock here *)
1440           else
1441             status
1442           else
1443             status) in status
1444                     
1445;;
1446
1447let serial_port_input status in_cont =
1448      (* Serial port input *)
1449  match in_cont with
1450      Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1451        (let status =
1452           (match line with
1453               `P1 b ->
1454                 if status.clock >= time then
1455                   { status with p1 = b; p1_latch = b; }
1456                 else
1457                   status
1458             | `P3 b ->
1459               if status.clock >= time then
1460                 { status with p3 = b; p3_latch = b; }
1461               else
1462                 status
1463             | `SerialBuff (`Eight b) ->
1464               let sm0 = get_bit status.scon 7 in
1465               let sm1 = get_bit status.scon 6 in
1466               (match (sm0, sm1) with
1467                   (false, false) ->
1468                       (* Mode 0: shift register.  No delay. *)
1469                     if status.clock >= time then
1470                       { status with scon = set_bit status.scon 0 true;
1471                         io   = cont;
1472                         sbuf = b }
1473                     else
1474                       status
1475                 | (false, true) ->
1476                       (* Mode 1: 8-bit UART *)
1477                       (* Explanation: 8 bit asynchronous communication.  There's a delay (epsilon)
1478                          which needs taking care of.  If we're trying to communicate at the same time
1479                          an existing communication is occurring, we assert false (else clause of first
1480                          if). *)
1481                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1482                     if status.clock >= time then
1483                           (* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1484                       if get_bit status.scon 5 then
1485                         assert false (* really: crash! *)
1486                       else
1487                         { status with serial_epsilon_in = Some (epsilon + time);
1488                           serial_v_in       = Some (`Eight b) }
1489                     else
1490                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1491                              None. *)
1492                       let Some e = status.serial_epsilon_in in
1493                       let Some v = status.serial_v_in in
1494                       if status.clock >= e then
1495                         match v with
1496                             `Eight v' ->
1497                               { status with sbuf = v';
1498                                 serial_v_in = None;
1499                                 serial_epsilon_in = None;
1500                                 scon = set_bit status.scon 0 true;
1501                                 io = cont }
1502                           | _ -> assert false (* trying to read in 9 bits instead of 8 *)
1503                       else
1504                         status
1505                   else
1506                     assert false
1507                 | (true, false) | (true, true) ->
1508                   assert false (* only got eight bits on the line when in 9 bit mode *))
1509             | `SerialBuff (`Nine (b,b')) ->
1510               let sm0 = get_bit status.scon 7 in
1511               let sm1 = get_bit status.scon 6 in
1512               match(sm0, sm1) with
1513                   (false, false) | (false, true) -> assert false
1514                 | (true, false)  | (true, true) ->
1515                       (* Modes 2 and 3: 9-bit UART *)
1516                       (* Explanation: 9 bit asynchronous communication.  There's a delay (epsilon)
1517                          which needs taking care of.  If we're trying to communicate at the same time
1518                          an existing communication is occurring, we assert false (else claus of first
1519                          if). *)
1520                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1521                     if status.clock >= time then
1522                           (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1523                       if get_bit status.scon 5 then
1524                         assert false (* really: crash! *)
1525                       else
1526                         { status with serial_epsilon_in = Some (epsilon + time);
1527                           serial_v_in       = Some (`Nine (b, b')) }
1528                     else
1529                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1530                              None. *)
1531                       let Some e = status.serial_epsilon_in in
1532                       let Some v = status.serial_v_in in
1533                       if status.clock >= e then
1534                         match v with
1535                             `Nine (v, v') ->
1536                               let scon' = set_bit status.scon 0 true in
1537                               { status with sbuf = v';
1538                                 serial_v_in = None;
1539                                 serial_epsilon_in = None;
1540                                 scon = set_bit scon' 2 b;
1541                                 io = cont }
1542                           | _ -> assert false (* trying to read in 8 bits instead of 9 *)
1543                       else
1544                         status
1545                   else
1546                     assert false)
1547         in
1548         { status with io = cont })
1549    | _ -> status
1550;;
1551
1552let serial_port_output status out_cont =
1553  (* Serial port output *)
1554  (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1555    serial_v_out = Some (`Eight status.sbuf);
1556    serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1557   match status.serial_epsilon_out with
1558       Some s ->
1559         if status.clock >= s then
1560           match status.serial_k_out with
1561               None -> assert false (* correct? *)
1562             | Some k' -> { status with io   = k';
1563               scon = set_bit status.scon 1 true; }
1564         else
1565           status
1566     | _ -> assert false)
1567;;
1568
1569let external_serial_interrupt status esi =
1570  (* Interrupt enabled *)
1571  if esi then
1572    (* If we're already running, then fine (todo: check for *another* interrupt
1573       and add to a queue, or something? *)
1574    if status.t1i_running then
1575      status
1576    else
1577      (* If we should be running, but aren't... *)
1578      if false then
1579        assert false
1580      else
1581        status
1582  else
1583    status
1584;;
1585
1586let external0_interrupt status e0i =
1587  (* Interrupt enabled *)
1588  if e0i then
1589    (* If we're already running, then fine (todo: check for *another* interrupt
1590       and add to a queue, or something? *)
1591    if status.t1i_running then
1592      status
1593    else
1594      (* If we should be running, but aren't... *)
1595      if false then
1596        assert false
1597      else
1598        status
1599  else
1600    status
1601;;
1602
1603let external1_interrupt status e1i =
1604  (* Interrupt enabled *)
1605  if e1i then
1606    (* If we're already running, then fine (todo: check for *another* interrupt
1607       and add to a queue, or something? *)
1608    if status.t1i_running then
1609      status
1610    else
1611      (* If we should be running, but aren't... *)
1612      if false then
1613        assert false
1614      else
1615        status
1616  else
1617    status
1618;;
1619
1620let timer0_interrupt status t0i =
1621  (* Interrupt enabled *)
1622  if t0i then
1623    (* If we're already running, then fine (todo: check for *another* interrupt
1624       and add to a queue, or something? *)
1625    if status.t1i_running then
1626      status
1627    else
1628      (* If we should be running, but aren't... *)
1629      if false then
1630        assert false
1631      else
1632        status
1633  else
1634    status
1635;;
1636
1637let timer1_interrupt status t1i =
1638  (* Interrupt enabled *)
1639  if t1i then
1640    (* If we're already running, then fine (todo: check for *another* interrupt
1641       and add to a queue, or something? *)
1642    if status.t1i_running then
1643      status
1644    else
1645      (* If we should be running, but aren't... *)
1646      if false then
1647        assert false
1648      else
1649        status
1650  else
1651    status
1652;;
1653
1654let interrupts status =
1655  let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1656  let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1657    (* DPM: are interrupts enabled? *)
1658  if ea then
1659    match (ps,pt1,px1,pt0,px0) with
1660        _ -> assert false
1661  else
1662    status
1663;;
1664
1665let execute1 status =
1666  let instr,pc,ticks = fetch status.code_memory status.pc in
1667  let status = { status with clock = status.clock + ticks; pc = pc } in
1668  let status =
1669    (match instr with
1670        `ADD (`A,d1) ->
1671          let v,c,ac,ov =
1672            add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1673          in
1674          set_flags (set_arg_8 status v `A) c (Some ac) ov
1675      | `ADDC (`A,d1) ->
1676        let v,c,ac,ov =
1677          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1678        in
1679        set_flags (set_arg_8 status v `A) c (Some ac) ov
1680      | `SUBB (`A,d1) ->
1681        let v,c,ac,ov =
1682          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1683        in
1684        set_flags (set_arg_8 status v `A) c (Some ac) ov
1685      | `INC `DPTR ->
1686        let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1687        let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1688        { status with dpl = low_order_byte; dph = high_order_byte }
1689      | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1690        let b = get_arg_8 status true d in
1691        let cry, res = half_add b (vect_of_int 1 `Eight) in
1692        set_arg_8 status res d
1693      | `DEC d ->
1694        let b = get_arg_8 status true d in
1695        let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1696        set_arg_8 status res d
1697      | `MUL (`A,`B) ->
1698        let acc = int_of_vect status.acc in
1699        let b = int_of_vect status.b in
1700        let prod = acc * b in
1701        let ov = prod > 255 in
1702        let l = vect_of_int (prod  mod 256) `Eight in
1703        let h = vect_of_int (prod / 256) `Eight in
1704        let status = { status with acc = l ; b = h } in
1705         (* DPM: Carry flag is always cleared. *)
1706        set_flags status false None ov
1707      | `DIV (`A,`B) ->
1708        let acc = int_of_vect status.acc in
1709        let b = int_of_vect status.b in
1710        if b = 0 then
1711        (* CSC: ACC and B undefined! We leave them as they are. *)
1712          set_flags status false None true
1713        else
1714          let q = vect_of_int (acc / b) `Eight in
1715          let r = vect_of_int (acc mod b) `Eight in
1716          let status = { status with acc = q ; b = r } in
1717          set_flags status false None false
1718      | `DA `A ->
1719        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1720        if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1721          let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1722          let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1723          if int_of_vect acc_upper_nibble > 9 or cy = true then
1724            let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1725            let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1726            set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1727          else
1728            status
1729        else
1730          status
1731      | `ANL (`U1(`A, ag)) ->
1732        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1733        set_arg_8 status and_val `A
1734      | `ANL (`U2((`DIRECT d), ag)) ->
1735        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1736        set_arg_8 status and_val (`DIRECT d)
1737      | `ANL (`U3 (`C, b)) ->
1738        let and_val = get_cy_flag status && get_arg_1 status true b in
1739        set_flags status and_val None (get_ov_flag status)
1740      | `ORL (`U1(`A, ag)) ->
1741        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1742        set_arg_8 status or_val `A
1743      | `ORL (`U2((`DIRECT d), ag)) ->
1744        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1745        set_arg_8 status or_val (`DIRECT d)
1746      | `ORL (`U3 (`C, b)) ->
1747        let or_val = get_cy_flag status || get_arg_1 status true b in
1748        set_flags status or_val None (get_ov_flag status)
1749      | `XRL (`U1(`A, ag)) ->
1750        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1751        set_arg_8 status xor_val `A
1752      | `XRL (`U2((`DIRECT d), ag)) ->
1753        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1754        set_arg_8 status xor_val (`DIRECT d)
1755      | `CLR `A -> set_arg_8 status (zero `Eight) `A
1756      | `CLR `C -> set_arg_1 status false `C
1757      | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1758      | `CPL `A -> { status with acc = complement status.acc }
1759      | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1760      | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1761      | `RL `A -> { status with acc = rotate_left status.acc }
1762      | `RLC `A ->
1763        let old_cy = get_cy_flag status in
1764        let n1, n2 = from_byte status.acc in
1765        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1766        let status = set_arg_1 status b1 `C in
1767        { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1768      | `RR `A -> { status with acc = rotate_right status.acc }
1769      | `RRC `A ->
1770        let old_cy = get_cy_flag status in
1771        let n1, n2 = from_byte status.acc in
1772        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1773        let status = set_arg_1 status b8 `C in
1774        { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1775      | `SWAP `A ->
1776        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1777        { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1778      | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1779      | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1780      | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1781      | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1782      | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1783      | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1784      | `MOVC (`A, `A_DPTR) ->
1785        let big_acc = mk_word (zero `Eight) status.acc in
1786        let dptr = mk_word status.dph status.dpl in
1787        let cry, addr = half_add dptr big_acc in
1788        let lookup = Physical.WordMap.find addr status.code_memory in
1789        { status with acc = lookup }
1790      | `MOVC (`A, `A_PC) ->
1791        let big_acc = mk_word (zero `Eight) status.acc in
1792        (* DPM: Under specified: does the carry from PC incrementation affect the *)
1793        (*      addition of the PC with the DPTR? At the moment, no.              *)
1794        let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1795        let status = { status with pc = inc_pc } in
1796        let cry,addr = half_add inc_pc big_acc in
1797        let lookup = Physical.WordMap.find addr status.code_memory in
1798        { status with acc = lookup }
1799      (* data transfer *)
1800      (* DPM: MOVX currently only implements the *copying* of data! *)
1801      | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1802      | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1803      | `SETB b -> set_arg_1 status true b
1804      | `PUSH a ->
1805       (* DPM: What happens if we overflow? *)
1806        let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1807        let status = { status with sp = new_sp } in
1808        write_at_sp status (get_arg_8 status false a)
1809      | `POP (`DIRECT b) ->
1810        let contents = read_at_sp status in
1811        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1812        let status = { status with sp = new_sp } in
1813        let status = set_arg_8 status contents (`DIRECT b) in
1814        status
1815      | `XCH(`A, arg) ->
1816        let old_arg = get_arg_8 status false arg in
1817        let old_acc = status.acc in
1818        let status = set_arg_8 status old_acc arg in
1819        { status with acc = old_arg }
1820      | `XCHD(`A, i) ->
1821        let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1822        let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1823        let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1824        let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1825        let status = { status with acc = new_acc } in
1826        set_arg_8 status new_reg i
1827      (* program branching *)
1828      | `JC (`REL rel) ->
1829        if get_cy_flag status then
1830          let cry, new_pc = half_add status.pc (sign_extension rel) in
1831          { status with pc = new_pc }
1832        else
1833          status
1834      | `JNC (`REL rel) ->
1835        if not $ get_cy_flag status then
1836          let cry, new_pc = half_add status.pc (sign_extension rel) in
1837          { status with pc = new_pc }
1838        else
1839          status
1840      | `JB (b, (`REL rel)) ->
1841        if get_arg_1 status false b then
1842          let cry, new_pc = half_add status.pc (sign_extension rel) in
1843          { status with pc = new_pc }
1844        else
1845          status
1846      | `JNB (b, (`REL rel)) ->
1847        if not $ get_arg_1 status false b then
1848          let cry, new_pc = half_add status.pc (sign_extension rel) in
1849          { status with pc = new_pc }
1850        else
1851          status
1852      | `JBC (b, (`REL rel)) ->
1853        let status = set_arg_1 status false b in
1854        if get_arg_1 status false b then
1855          let cry, new_pc = half_add status.pc (sign_extension rel) in
1856          { status with pc = new_pc }
1857        else
1858          status
1859      | `RET ->
1860        (* DPM: What happens when we underflow? *)
1861        let high_bits = read_at_sp status in
1862        let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1863        let status = { status with sp = new_sp } in
1864        let low_bits = read_at_sp status in
1865        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1866        let status = { status with sp = new_sp } in
1867        { status with pc = mk_word high_bits low_bits }
1868      | `RETI ->
1869        let high_bits = read_at_sp status in
1870        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1871        let status = { status with sp = new_sp } in
1872        let low_bits = read_at_sp status in
1873        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1874        let status = { status with sp = new_sp } in
1875        { status with pc = mk_word high_bits low_bits }
1876      | `ACALL (`ADDR11 a) ->
1877        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1878        let status = { status with sp = new_sp } in
1879        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1880        let status = write_at_sp status pc_lower_byte in
1881        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1882        let status = { status with sp = new_sp } in
1883        let status = write_at_sp status pc_upper_byte in
1884        let addr = addr16_of_addr11 status.pc a in
1885        { status with pc = addr }
1886      | `LCALL (`ADDR16 addr) ->
1887        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1888        let status = { status with sp = new_sp } in
1889        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1890        let status = write_at_sp status pc_lower_byte in
1891        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1892        let status = { status with sp = new_sp } in
1893        let status = write_at_sp status pc_upper_byte in
1894        { status with pc = addr }
1895      | `AJMP (`ADDR11 a) ->
1896        let addr = addr16_of_addr11 status.pc a in
1897        { status with pc = addr }
1898      | `LJMP (`ADDR16 a) ->
1899        { status with pc = a }
1900      | `SJMP (`REL rel) ->
1901        let cry, new_pc = half_add status.pc (sign_extension rel) in
1902        { status with pc = new_pc }
1903      | `JMP `IND_DPTR ->
1904        let dptr = mk_word status.dph status.dpl in
1905        let big_acc = mk_word (zero `Eight) status.acc in
1906        let cry, jmp_addr = half_add big_acc dptr in
1907        let cry, new_pc = half_add status.pc jmp_addr in
1908        { status with pc = new_pc }
1909      | `JZ (`REL rel) ->
1910        if status.acc = zero `Eight then
1911          let cry, new_pc = half_add status.pc (sign_extension rel) in
1912          { status with pc = new_pc }
1913        else
1914          status
1915      | `JNZ (`REL rel) ->
1916        if status.acc <> zero `Eight then
1917          let cry, new_pc = half_add status.pc (sign_extension rel) in
1918          { status with pc = new_pc }
1919        else
1920          status
1921      | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1922        let new_carry = status.acc < get_arg_8 status false ag in
1923        if get_arg_8 status false ag <> status.acc then
1924          let cry, new_pc = half_add status.pc (sign_extension rel) in
1925          let status = set_flags status new_carry None (get_ov_flag status) in
1926          { status with pc = new_pc;  }
1927        else
1928          set_flags status new_carry None (get_ov_flag status)
1929      | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1930        let new_carry = get_arg_8 status false ag < d in
1931        if get_arg_8 status false ag <> d then
1932          let cry, new_pc = half_add status.pc (sign_extension rel) in
1933          let status = { status with pc = new_pc } in
1934          set_flags status new_carry None (get_ov_flag status)
1935        else
1936          set_flags status new_carry None (get_ov_flag status)
1937      | `DJNZ (ag, (`REL rel)) ->
1938        let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1939        let status = set_arg_8 status new_ag ag in
1940        if new_ag <> zero `Eight then
1941          let cry, new_pc = half_add status.pc (sign_extension rel) in
1942          { status with pc = new_pc }
1943        else
1944          status
1945      | `NOP -> status) in
1946  let status = timers status ticks in
1947  let in_cont, `Out out_cont = status.io in
1948  let status = serial_port_input status in_cont in
1949  let status = serial_port_output status out_cont in
1950  let status = interrupts status in
1951  { status with previous_p1_val = get_bit status.p3 4;
1952    previous_p3_val = get_bit status.p3 5 }
1953;;
1954
1955(*
1956OLD output routine:
1957           (* Serial port output, part one *)
1958           let status =
1959             (match status.expected_out_time with
1960               `At t when status.clock >= t ->
1961                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1962              | _ -> status) in
1963
1964             (if status.expected_out_time = `Now then
1965               if get_bit status.scon 7 then
1966                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1967                   { status with expected_out_time = `At exp_time; io = new_cont }
1968               else
1969                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1970                   { status with expected_out_time = `At exp_time; io = new_cont }               
1971             else
1972               status) in
1973*)
1974
1975let rec execute f s =
1976  let cont =
1977    try f s; true
1978    with Halt -> false
1979  in
1980  if cont then execute f (execute1 s)
1981  else s
1982;;
1983
1984
1985let load_program p =
1986  let st = load p.ASM.code initialize in
1987  { st with exit_addr = p.ASM.exit_addr (* ; cost_labels = p.ASM.cost_labels *)}
1988
1989type cost_trace = {
1990        mutable ct_labels : CostLabel.t list;
1991        mutable ct_inds   : CostLabel.const_indexing list;
1992}
1993
1994(* TODO: supposing only one index reset or increment per instruction *)
1995let update_indexes trace p st =
1996  try
1997    let i = BitVectors.WordMap.find st.pc p.ASM.inds in
1998                CostLabel.enter_loop trace.ct_inds i
1999  with Not_found -> ();
2000  try
2001    let i = BitVectors.WordMap.find st.pc p.ASM.incs in
2002    CostLabel.continue_loop trace.ct_inds i
2003  with Not_found -> ();
2004  let instr,_,_ = fetch st.code_memory st.pc in
2005        match instr with
2006                | `ACALL _ | `LCALL _ ->
2007      trace.ct_inds <- CostLabel.new_const_ind trace.ct_inds
2008                | `RET ->
2009                        trace.ct_inds <- CostLabel.forget_const_ind trace.ct_inds
2010                | _ -> ()
2011
2012let update_labels trace p st =
2013  try
2014    let cost_label = BitVectors.WordMap.find st.pc p.cost_labels in
2015        let ind = CostLabel.curr_const_ind trace.ct_inds in
2016        let cost_label = CostLabel.ev_indexing ind cost_label in
2017        trace.ct_labels <- cost_label :: trace.ct_labels
2018  with Not_found -> ()
2019
2020
2021
2022let update_trace trace p st =
2023        update_labels trace p st;
2024        update_indexes trace p st;
2025  if st.pc = st.exit_addr (* <=> end of program *) then raise Halt else st
2026
2027let result st =
2028  let dpl = st.dpl in
2029  let dpr = st.dph in
2030  let addr i = BitVectors.vect_of_int i `Seven in
2031  let get_ireg i = Physical.Byte7Map.find (addr i) st.low_internal_ram in
2032  let r00 = get_ireg 0 in
2033  let r01 = get_ireg 1 in
2034  let is = [dpl ; dpr ; r00 ; r01] in
2035  let f i = IntValue.Int32.of_int (BitVectors.int_of_vect i) in
2036  IntValue.Int32.merge (List.map f is)
2037
2038let interpret debug p =
2039  Printf.printf "*** 8051 interpret ***\n%!" ;
2040  if p.ASM.has_main then
2041    let st = load_program p in
2042    let trace = {ct_labels = []; ct_inds = []} in
2043    let callback = update_trace trace p in
2044    let st = execute callback st in
2045    let res = result st in
2046    if debug then
2047      Printf.printf "Result = %s\n%!" (IntValue.Int32.to_string res) ;
2048    (res, List.rev trace.ct_labels)
2049  else (IntValue.Int32.zero, [])
Note: See TracBrowser for help on using the repository browser.