source: Deliverables/D2.2/8051/src/ASM/ASMInterpret.ml @ 1542

Last change on this file since 1542 was 1542, checked in by tranquil, 8 years ago

merge of indexed labels branch

File size: 81.8 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 3 `Sixteen))), exit_addr, labels, inds, incs, costs
971
972      | `Jmp _ 
973      | `Call _ -> (snd (half_add pc (BitVectors.vect_of_int 3 `Sixteen))), exit_addr, labels, inds, incs, costs
974      (*CSC: very stupid: always expand to worst opcode *)
975      | `WithLabel i ->
976        let fake_addr _ = `REL (zero `Eight) in
977        let fake_jump = assembly_jump fake_addr i in
978        let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
979        assert (fake_jump = i');
980        let pc' = snd (half_add pc' (vect_of_int 5 `Sixteen)) in
981          (snd (half_add pc pc'), exit_addr, labels, inds, incs, costs)
982      | #instruction as i ->
983        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
984         assert (i = i');
985         (snd (half_add pc pc'),exit_addr,labels, inds, incs, costs)
986   )
987    (BitVectors.zero `Sixteen,BitVectors.zero `Sixteen,
988     StringTools.Map.empty, BitVectors.WordMap.empty, BitVectors.WordMap.empty,
989     BitVectors.WordMap.empty) p.ASM.pcode
990 in
991 let code =
992  List.flatten (List.map
993     (function
994        `Label _
995      | `Cost _
996      | `Index _
997      | `Inc _ -> []
998      | `WithLabel i ->
999         (* We need to expand a conditional jump to a label to a machine language
1000            conditional jump.  Suppose we have:
1001              JC label
1002            This should be expanded to:
1003              JC 2         -- size of a short jump
1004              SJMP 3       -- size of a long jump
1005              LJMP offset  -- offset = position of label in code
1006            And, for ever label appearing after the location of the jump in code
1007            memory, we must increment by 5, as we added two new instructions. *)
1008        let to_ljmp = `REL (vect_of_int 2 `Eight) in
1009        let offset = 5 in
1010         let jmp_address, translated_jump =
1011           match i with
1012             `JC (`Label a) ->
1013               let address = StringTools.Map.find a labels in
1014               let reconstructed = `JC to_ljmp in
1015                 address, reconstructed
1016           | `JNC (`Label a) ->
1017               let address = StringTools.Map.find a labels in
1018               let reconstructed = `JNC to_ljmp in
1019                 address, reconstructed
1020           | `JB (b, `Label a) ->
1021               let address = StringTools.Map.find a labels in
1022               let reconstructed = `JB (b, to_ljmp) in
1023                 address, reconstructed
1024           | `JNB (b, `Label a) ->
1025               let address = StringTools.Map.find a labels in
1026               let reconstructed = `JNB (b, to_ljmp) in
1027                 address, reconstructed
1028           | `JBC (b, `Label a) ->
1029               let address = StringTools.Map.find a labels in
1030               let reconstructed = `JBC (b, to_ljmp) in
1031                 address, reconstructed
1032           | `JZ (`Label a) ->
1033               let address = StringTools.Map.find a labels in
1034               let reconstructed = `JZ (to_ljmp) in
1035                 address, reconstructed
1036           | `JNZ (`Label a) ->
1037               let address = StringTools.Map.find a labels in
1038               let reconstructed = `JNZ (to_ljmp) in
1039                 address, reconstructed
1040           | `CJNE (args, `Label a) ->
1041               let address = StringTools.Map.find a labels in
1042               let reconstructed = `CJNE (args, to_ljmp) in
1043                 address, reconstructed
1044           | `DJNZ (args, `Label a) ->
1045               let address = StringTools.Map.find a labels in
1046               let reconstructed = `DJNZ (args, to_ljmp) in
1047                 address, reconstructed
1048         in
1049           let sjmp = `SJMP (`REL (vect_of_int 3 `Eight)) in
1050           let jmp = `LJMP (`ADDR16 jmp_address) in
1051           let translation = [ translated_jump; sjmp; jmp ] in
1052             List.flatten (List.map assembly1 translation)
1053      | `Mov (`DPTR,s) ->
1054          (* let addr16 = StringTools.Map.find s datalabels in *)
1055          let addrr16 =
1056            try StringTools.Map.find s datalabels
1057            with Not_found -> StringTools.Map.find s labels in
1058          assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
1059      | `Jmp s ->
1060          let pc_offset = StringTools.Map.find s labels in
1061            assembly1 (`LJMP (`ADDR16 pc_offset))
1062      | `Call s ->
1063          let pc_offset = StringTools.Map.find s labels in
1064            assembly1 (`LCALL (`ADDR16 pc_offset ))
1065      | #instruction as i -> assembly1 i) p.ASM.pcode) in
1066 { ASM.code = code ;
1067   ASM.inds = inds; ASM.incs = incs; ASM.cost_labels = costs ;
1068   ASM.labels = StringTools.Map.empty ;
1069   ASM.exit_addr = exit_addr ; ASM.has_main = p.ASM.phas_main }
1070;;
1071
1072let set_register status v reg =
1073  let addr = get_address_of_register status reg in
1074    { status with low_internal_ram =
1075        Byte7Map.add addr v status.low_internal_ram }
1076;;
1077
1078let get_arg_8 status from_latch = 
1079 function
1080    `DIRECT addr ->
1081       let n0, n1 = from_byte addr in
1082       (match from_nibble n0 with
1083          (false,r1,r2,r3) ->
1084            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
1085        | _ -> get_sfr status addr from_latch)
1086  | `INDIRECT b ->
1087       let (b1, b2) = from_byte (get_register status (false,false,b)) in
1088         (match (from_nibble b1, b2) with 
1089           (false,r1,r2,r3),b2 ->
1090             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
1091         | (true,r1,r2,r3),b2 ->
1092             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
1093  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
1094  | `A -> status.acc
1095  | `B -> status.b
1096  | `DATA b -> b
1097  | `A_DPTR ->
1098       let dpr = mk_word status.dph status.dpl in
1099       (* CSC: what is the right behaviour in case of overflow?
1100          assert false for now. Try to understand what DEC really does *)
1101       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
1102         Physical.WordMap.find addr status.external_ram
1103  | `A_PC ->
1104       (* CSC: what is the right behaviour in case of overflow?
1105          assert false for now *)
1106       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
1107         Physical.WordMap.find addr status.external_ram
1108  | `EXT_INDIRECT b ->
1109         let addr = get_register status (false,false,b) in
1110           Physical.WordMap.find (mk_word (zero `Eight) addr) status.external_ram
1111  | `EXT_IND_DPTR ->
1112       let dpr = mk_word status.dph status.dpl in
1113         Physical.WordMap.find dpr status.external_ram
1114;;
1115
1116let get_arg_16 _status = function `DATA16 w -> w
1117
1118let get_arg_1 status from_latch =
1119  function
1120    `BIT addr
1121  | `NBIT addr as x ->
1122     let n1, n2 = from_byte addr in
1123     let res =
1124      (match from_nibble n1 with
1125         (false,r1,r2,r3) ->
1126           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1127           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1128             get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1129        | (true,r1,r2,r3) ->
1130            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1131            let div = addr / 8 in
1132            let rem = addr mod 8 in
1133              get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1134    in (match x with `NBIT _ -> not res | _ -> res)
1135  | `C -> get_cy_flag status
1136
1137let set_arg_1 status v =
1138  function
1139    `BIT addr ->
1140      let n1, n2 = from_byte addr in
1141      (match from_nibble n1 with
1142         (false,r1,r2,r3) ->
1143           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1144           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1145           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1146             { status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1147      | (true,r1,r2,r3) ->
1148            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1149            let div = addr / 8 in
1150            let rem = addr mod 8 in
1151            let addr' = vect_of_int ((div * 8) + 128) `Eight in
1152            let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1153            let sfr' = set_bit sfr rem v in
1154              set_sfr status addr' sfr')
1155    | `C ->
1156       let (n1,n2) = from_byte status.psw in
1157       let (_,b2,b3,b4) = from_nibble n1 in
1158         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1159
1160let set_arg_8 status v =
1161  function
1162  `DIRECT addr ->
1163    let (b1, b2) = from_byte addr in
1164    (match from_nibble b1 with
1165        (false,r1,r2,r3) ->
1166          { status with low_internal_ram =
1167              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1168      | _ -> set_sfr status addr v)
1169    | `INDIRECT b ->
1170      let (b1, b2) = from_byte (get_register status (false,false,b)) in
1171      (match (from_nibble b1, b2) with 
1172          (false,r1,r2,r3),n1 ->
1173            { status with low_internal_ram =
1174                Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1175        | (true,r1,r2,r3),n1 ->
1176          { status with high_internal_ram =
1177              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1178    | `REG (b1,b2,b3) ->
1179      set_register status v (b1,b2,b3)
1180    | `A -> { status with acc = v }
1181    | `B -> { status with b = v }
1182    | `EXT_IND_DPTR ->
1183      let dpr = mk_word status.dph status.dpl in
1184      { status with external_ram =
1185          Physical.WordMap.add dpr v status.external_ram }
1186    | `EXT_INDIRECT b ->
1187      let addr = get_register status (false,false,b) in
1188      { status with external_ram =
1189          Physical.WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1190;;
1191
1192let set_arg_16 status wrd =
1193  function
1194  `DPTR ->
1195    let (dh, dl) = from_word wrd in
1196    { status with dph = dh; dpl = dl }
1197     
1198let set_flags status c ac ov =
1199  { status with psw =
1200      let bu,bl = from_byte status.psw in
1201      let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1202      let ac = match ac with None -> oac | Some v -> v in
1203      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1204  }
1205;;
1206
1207let xor b1 b2 =
1208  if b1 = true && b2 = true then
1209    false
1210  else if b1 = false && b2 = false then
1211    false
1212  else true
1213;;
1214
1215let read_at_sp status =
1216  let n1,n2 = from_byte status.sp in
1217  let m,r1,r2,r3 = from_nibble n1 in
1218  Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1219    (if m then status.low_internal_ram else status.high_internal_ram)
1220;;
1221
1222let write_at_sp status v =
1223  let n1,n2 = from_byte status.sp in
1224  match from_nibble n1 with
1225      true,r1,r2,r3 ->
1226        let memory =
1227          Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1228        in
1229        { status with low_internal_ram = memory }
1230    | false,r1,r2,r3 ->
1231      let memory =
1232        Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1233      in
1234      { status with high_internal_ram = memory }
1235;;
1236
1237let timer0 status b1 b2 ticks =
1238  let b = get_bit status.tcon 4 in
1239          (* Timer0 first *)
1240  (match b1,b2 with
1241      true,true ->
1242              (* Archaic 13 bit mode. *)
1243        if b then
1244          let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1245          let res = int_of_vect res in
1246          if res > 31 then
1247            let res = res mod 32 in
1248            let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1249            if ov' then
1250              let b = set_bit status.tcon 7 true in
1251              { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1252            else
1253              { status with th0 = res'; tl0 = vect_of_int res `Eight }
1254          else
1255            { status with tl0 = vect_of_int res `Eight }
1256        else
1257          status
1258    | false,false ->
1259              (* 8 bit split timer mode. *)
1260      let status = 
1261        (if b then
1262            let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1263            if ov then
1264              let b = set_bit status.tcon 5 true in
1265              { status with tcon = b; tl0 = res }
1266            else
1267              { status with tl0 = res }
1268         else
1269            status)
1270      in
1271      if get_bit status.tcon 6 then
1272        let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1273        if ov then
1274          let b = set_bit status.tcon 7 true in
1275          { status with tcon = b; th0 = res }
1276        else
1277          { status with th0 = res }
1278      else
1279        status
1280    | false,true ->
1281             (* 16 bit timer mode. *)
1282      if b then
1283        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1284                if ov then
1285                  let b = set_bit status.tcon 5 true in
1286                  let new_th0,new_tl0 = from_word res in
1287                  { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1288                else
1289                  let new_th0,new_tl0 = from_word res in
1290                  { status with th0 = new_th0; tl0 = new_tl0 }
1291      else
1292        status
1293    | true,false ->
1294              (* 8 bit single timer mode. *)
1295      if b then
1296        let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1297        if ov then
1298          let b = set_bit status.tcon 5 true in
1299          { status with tcon = b; tl0 = status.th0; }
1300        else
1301          { status with tl0 = res }
1302      else
1303        status)
1304   
1305let timer1 status b3 b4 ticks =
1306  let b = get_bit status.tcon 4 in
1307  (match b3,b4 with
1308      true,true ->
1309        (* Archaic 13 bit mode. *)
1310        if b then
1311          let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1312          let res = int_of_vect res in
1313          if res > 31 then
1314            let res = res mod 32 in
1315            let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1316            if ov' then
1317              let b = set_bit status.tcon 7 true in
1318              { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1319            else
1320              { status with th1 = res'; tl0 = vect_of_int res `Eight }
1321          else
1322            { status with tl1 = vect_of_int res `Eight }
1323        else
1324          status
1325    | false,false ->
1326              (* 8 bit split timer mode. *)
1327      let status = 
1328        (if b then
1329            let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1330            if ov then
1331              let b = set_bit status.tcon 5 true in
1332                        { status with tcon = b; tl1 = res }
1333            else
1334              { status with tl1 = res }
1335         else
1336            status)
1337      in
1338      if get_bit status.tcon 6 then
1339        let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1340        if ov then
1341          let b = set_bit status.tcon 7 true in
1342          { status with tcon = b; th1 = res }
1343        else
1344          { status with th1 = res }
1345      else
1346        status
1347    | false,true ->
1348             (* 16 bit timer mode. *)
1349      if b then
1350        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1351        if ov then
1352          let b = set_bit status.tcon 5 true in
1353          let new_th1,new_tl1 = from_word res in
1354          { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1355        else
1356          let new_th1,new_tl1 = from_word res in
1357          { status with th1 = new_th1; tl1 = new_tl1 }
1358      else
1359        status
1360    | true,false ->
1361              (* 8 bit single timer mode. *)
1362      if b then
1363        let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1364        if ov then
1365          let b = set_bit status.tcon 5 true in
1366          { status with tcon = b; tl1 = status.th1; }
1367        else
1368          { status with tl1 = res }
1369      else
1370        status)
1371;;
1372
1373let timers status ticks =
1374  (* DPM: Clock/Timer code follows. *)
1375  match bits_of_byte status.tmod with
1376    | (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1377      let status =
1378        (if g0 then
1379            if get_bit status.p3 2 then
1380              if c0 then
1381                if status.previous_p1_val && not $ get_bit status.p3 4 then
1382                  timer0 status b1 b2 ticks
1383                else
1384                  status
1385              else
1386                timer0 status b1 b2 ticks
1387            else
1388              status
1389         else
1390            timer0 status b1 b2 ticks) in
1391      (* Timer 1 follows. *)
1392      let status =
1393        (if g1 then
1394            if get_bit status.p1 3 then
1395              if c1 then
1396                if status.previous_p3_val && not $ get_bit status.p3 5 then
1397                  timer1 status b3 b4 ticks
1398                else
1399                  status
1400              else
1401                timer1 status b3 b4 ticks
1402            else
1403              status
1404         else
1405            timer1 status b3 b4 ticks) in
1406      (* Timer 2 follows *)
1407      let status =
1408        (let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in
1409          (* Timer2 is enabled *)
1410         if tr2 then
1411            (* Counter/interval mode *)
1412           if ct2 && not cp2 then
1413             let word = mk_word status.th2 status.tl2 in
1414             let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in
1415             if ov then
1416               let new_th2 = status.rcap2h in
1417               let new_tl2 = status.rcap2l in
1418                  (* Overflow flag not set if either of the following flags are set *)
1419               if not rclk && not tclk then
1420                 let b = set_bit status.t2con 7 true in
1421                 { status with t2con = b;
1422                   th2 = new_th2;
1423                   tl2 = new_tl2 }
1424               else
1425                 { status with th2 = new_th2;
1426                   tl2 = new_tl2 }
1427             else
1428                (* Reload also signalled when a 1-0 transition is detected *)
1429               if status.previous_p1_val && not $ get_bit status.p1 1 then
1430                  (* In which case signal reload by setting T2CON.6 *)
1431                 let b = set_bit status.t2con 6 true in
1432                 { status with th2 = status.rcap2h;
1433                   tl2 = status.rcap2l;
1434                   t2con = b }
1435               else
1436                 let new_th2, new_tl2 = from_word res in
1437                 { status with th2 = new_th2;
1438                   tl2 = new_tl2 }
1439            (* Capture mode *)
1440           else if cp2 && exen2 then
1441              (* 1-0 transition detected *)
1442              (* DPM: look at this: is the timer still running throughout? *)
1443             if status.previous_p1_val && not $ get_bit status.p1 1 then
1444               status (* Implement clock here *)
1445             else
1446               status (* Implement clock here *)
1447           else
1448             status
1449           else
1450             status) in status
1451                     
1452;;
1453
1454let serial_port_input status in_cont =
1455      (* Serial port input *)
1456  match in_cont with
1457      Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1458        (let status =
1459           (match line with
1460               `P1 b ->
1461                 if status.clock >= time then
1462                   { status with p1 = b; p1_latch = b; }
1463                 else
1464                   status
1465             | `P3 b ->
1466               if status.clock >= time then
1467                 { status with p3 = b; p3_latch = b; }
1468               else
1469                 status
1470             | `SerialBuff (`Eight b) ->
1471               let sm0 = get_bit status.scon 7 in
1472               let sm1 = get_bit status.scon 6 in
1473               (match (sm0, sm1) with
1474                   (false, false) ->
1475                       (* Mode 0: shift register.  No delay. *)
1476                     if status.clock >= time then
1477                       { status with scon = set_bit status.scon 0 true;
1478                         io   = cont;
1479                         sbuf = b }
1480                     else
1481                       status
1482                 | (false, true) ->
1483                       (* Mode 1: 8-bit UART *)
1484                       (* Explanation: 8 bit asynchronous communication.  There's a delay (epsilon)
1485                          which needs taking care of.  If we're trying to communicate at the same time
1486                          an existing communication is occurring, we assert false (else clause of first
1487                          if). *)
1488                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1489                     if status.clock >= time then
1490                           (* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1491                       if get_bit status.scon 5 then
1492                         assert false (* really: crash! *)
1493                       else
1494                         { status with serial_epsilon_in = Some (epsilon + time);
1495                           serial_v_in       = Some (`Eight b) }
1496                     else
1497                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1498                              None. *)
1499                       let Some e = status.serial_epsilon_in in
1500                       let Some v = status.serial_v_in in
1501                       if status.clock >= e then
1502                         match v with
1503                             `Eight v' ->
1504                               { status with sbuf = v';
1505                                 serial_v_in = None;
1506                                 serial_epsilon_in = None;
1507                                 scon = set_bit status.scon 0 true;
1508                                 io = cont }
1509                           | _ -> assert false (* trying to read in 9 bits instead of 8 *)
1510                       else
1511                         status
1512                   else
1513                     assert false
1514                 | (true, false) | (true, true) ->
1515                   assert false (* only got eight bits on the line when in 9 bit mode *))
1516             | `SerialBuff (`Nine (b,b')) ->
1517               let sm0 = get_bit status.scon 7 in
1518               let sm1 = get_bit status.scon 6 in
1519               match(sm0, sm1) with
1520                   (false, false) | (false, true) -> assert false
1521                 | (true, false)  | (true, true) ->
1522                       (* Modes 2 and 3: 9-bit UART *)
1523                       (* Explanation: 9 bit asynchronous communication.  There's a delay (epsilon)
1524                          which needs taking care of.  If we're trying to communicate at the same time
1525                          an existing communication is occurring, we assert false (else claus of first
1526                          if). *)
1527                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1528                     if status.clock >= time then
1529                           (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1530                       if get_bit status.scon 5 then
1531                         assert false (* really: crash! *)
1532                       else
1533                         { status with serial_epsilon_in = Some (epsilon + time);
1534                           serial_v_in       = Some (`Nine (b, b')) }
1535                     else
1536                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1537                              None. *)
1538                       let Some e = status.serial_epsilon_in in
1539                       let Some v = status.serial_v_in in
1540                       if status.clock >= e then
1541                         match v with
1542                             `Nine (v, v') ->
1543                               let scon' = set_bit status.scon 0 true in
1544                               { status with sbuf = v';
1545                                 serial_v_in = None;
1546                                 serial_epsilon_in = None;
1547                                 scon = set_bit scon' 2 b;
1548                                 io = cont }
1549                           | _ -> assert false (* trying to read in 8 bits instead of 9 *)
1550                       else
1551                         status
1552                   else
1553                     assert false)
1554         in
1555         { status with io = cont })
1556    | _ -> status
1557;;
1558
1559let serial_port_output status out_cont =
1560  (* Serial port output *)
1561  (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1562    serial_v_out = Some (`Eight status.sbuf);
1563    serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1564   match status.serial_epsilon_out with
1565       Some s ->
1566         if status.clock >= s then
1567           match status.serial_k_out with
1568               None -> assert false (* correct? *)
1569             | Some k' -> { status with io   = k';
1570               scon = set_bit status.scon 1 true; }
1571         else
1572           status
1573     | _ -> assert false)
1574;;
1575
1576let external_serial_interrupt status esi =
1577  (* Interrupt enabled *)
1578  if esi then
1579    (* If we're already running, then fine (todo: check for *another* interrupt
1580       and add to a queue, or something? *)
1581    if status.t1i_running then
1582      status
1583    else
1584      (* If we should be running, but aren't... *)
1585      if false then
1586        assert false
1587      else
1588        status
1589  else
1590    status
1591;;
1592
1593let external0_interrupt status e0i =
1594  (* Interrupt enabled *)
1595  if e0i then
1596    (* If we're already running, then fine (todo: check for *another* interrupt
1597       and add to a queue, or something? *)
1598    if status.t1i_running then
1599      status
1600    else
1601      (* If we should be running, but aren't... *)
1602      if false then
1603        assert false
1604      else
1605        status
1606  else
1607    status
1608;;
1609
1610let external1_interrupt status e1i =
1611  (* Interrupt enabled *)
1612  if e1i then
1613    (* If we're already running, then fine (todo: check for *another* interrupt
1614       and add to a queue, or something? *)
1615    if status.t1i_running then
1616      status
1617    else
1618      (* If we should be running, but aren't... *)
1619      if false then
1620        assert false
1621      else
1622        status
1623  else
1624    status
1625;;
1626
1627let timer0_interrupt status t0i =
1628  (* Interrupt enabled *)
1629  if t0i then
1630    (* If we're already running, then fine (todo: check for *another* interrupt
1631       and add to a queue, or something? *)
1632    if status.t1i_running then
1633      status
1634    else
1635      (* If we should be running, but aren't... *)
1636      if false then
1637        assert false
1638      else
1639        status
1640  else
1641    status
1642;;
1643
1644let timer1_interrupt status t1i =
1645  (* Interrupt enabled *)
1646  if t1i then
1647    (* If we're already running, then fine (todo: check for *another* interrupt
1648       and add to a queue, or something? *)
1649    if status.t1i_running then
1650      status
1651    else
1652      (* If we should be running, but aren't... *)
1653      if false then
1654        assert false
1655      else
1656        status
1657  else
1658    status
1659;;
1660
1661let interrupts status =
1662  let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1663  let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1664    (* DPM: are interrupts enabled? *)
1665  if ea then
1666    match (ps,pt1,px1,pt0,px0) with
1667        _ -> assert false
1668  else
1669    status
1670;;
1671
1672let execute1 status =
1673  let instr,pc,ticks = fetch status.code_memory status.pc in
1674  let status = { status with clock = status.clock + ticks; pc = pc } in
1675  let status =
1676    (match instr with
1677        `ADD (`A,d1) ->
1678          let v,c,ac,ov =
1679            add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1680          in
1681          set_flags (set_arg_8 status v `A) c (Some ac) ov
1682      | `ADDC (`A,d1) ->
1683        let v,c,ac,ov =
1684          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1685        in
1686        set_flags (set_arg_8 status v `A) c (Some ac) ov
1687      | `SUBB (`A,d1) ->
1688        let v,c,ac,ov =
1689          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1690        in
1691        set_flags (set_arg_8 status v `A) c (Some ac) ov
1692      | `INC `DPTR ->
1693        let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1694        let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1695        { status with dpl = low_order_byte; dph = high_order_byte }
1696      | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1697        let b = get_arg_8 status true d in
1698        let cry, res = half_add b (vect_of_int 1 `Eight) in
1699        set_arg_8 status res d
1700      | `DEC d ->
1701        let b = get_arg_8 status true d in
1702        let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1703        set_arg_8 status res d
1704      | `MUL (`A,`B) ->
1705        let acc = int_of_vect status.acc in
1706        let b = int_of_vect status.b in
1707        let prod = acc * b in
1708        let ov = prod > 255 in
1709        let l = vect_of_int (prod  mod 256) `Eight in
1710        let h = vect_of_int (prod / 256) `Eight in
1711        let status = { status with acc = l ; b = h } in
1712         (* DPM: Carry flag is always cleared. *)
1713        set_flags status false None ov
1714      | `DIV (`A,`B) ->
1715        let acc = int_of_vect status.acc in
1716        let b = int_of_vect status.b in
1717        if b = 0 then
1718        (* CSC: ACC and B undefined! We leave them as they are. *)
1719          set_flags status false None true
1720        else
1721          let q = vect_of_int (acc / b) `Eight in
1722          let r = vect_of_int (acc mod b) `Eight in
1723          let status = { status with acc = q ; b = r } in
1724          set_flags status false None false
1725      | `DA `A ->
1726        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1727        if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1728          let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1729          let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1730          if int_of_vect acc_upper_nibble > 9 or cy = true then
1731            let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1732            let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1733            set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1734          else
1735            status
1736        else
1737          status
1738      | `ANL (`U1(`A, ag)) ->
1739        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1740        set_arg_8 status and_val `A
1741      | `ANL (`U2((`DIRECT d), ag)) ->
1742        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1743        set_arg_8 status and_val (`DIRECT d)
1744      | `ANL (`U3 (`C, b)) ->
1745        let and_val = get_cy_flag status && get_arg_1 status true b in
1746        set_flags status and_val None (get_ov_flag status)
1747      | `ORL (`U1(`A, ag)) ->
1748        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1749        set_arg_8 status or_val `A
1750      | `ORL (`U2((`DIRECT d), ag)) ->
1751        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1752        set_arg_8 status or_val (`DIRECT d)
1753      | `ORL (`U3 (`C, b)) ->
1754        let or_val = get_cy_flag status || get_arg_1 status true b in
1755        set_flags status or_val None (get_ov_flag status)
1756      | `XRL (`U1(`A, ag)) ->
1757        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1758        set_arg_8 status xor_val `A
1759      | `XRL (`U2((`DIRECT d), ag)) ->
1760        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1761        set_arg_8 status xor_val (`DIRECT d)
1762      | `CLR `A -> set_arg_8 status (zero `Eight) `A
1763      | `CLR `C -> set_arg_1 status false `C
1764      | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1765      | `CPL `A -> { status with acc = complement status.acc }
1766      | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1767      | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1768      | `RL `A -> { status with acc = rotate_left status.acc }
1769      | `RLC `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 b1 `C in
1774        { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1775      | `RR `A -> { status with acc = rotate_right status.acc }
1776      | `RRC `A ->
1777        let old_cy = get_cy_flag status in
1778        let n1, n2 = from_byte status.acc in
1779        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1780        let status = set_arg_1 status b8 `C in
1781        { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1782      | `SWAP `A ->
1783        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1784        { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1785      | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1786      | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1787      | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1788      | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1789      | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1790      | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1791      | `MOVC (`A, `A_DPTR) ->
1792        let big_acc = mk_word (zero `Eight) status.acc in
1793        let dptr = mk_word status.dph status.dpl in
1794        let cry, addr = half_add dptr big_acc in
1795        let lookup = Physical.WordMap.find addr status.code_memory in
1796        { status with acc = lookup }
1797      | `MOVC (`A, `A_PC) ->
1798        let big_acc = mk_word (zero `Eight) status.acc in
1799        (* DPM: Under specified: does the carry from PC incrementation affect the *)
1800        (*      addition of the PC with the DPTR? At the moment, no.              *)
1801        let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1802        let status = { status with pc = inc_pc } in
1803        let cry,addr = half_add inc_pc big_acc in
1804        let lookup = Physical.WordMap.find addr status.code_memory in
1805        { status with acc = lookup }
1806      (* data transfer *)
1807      (* DPM: MOVX currently only implements the *copying* of data! *)
1808      | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1809      | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1810      | `SETB b -> set_arg_1 status true b
1811      | `PUSH a ->
1812       (* DPM: What happens if we overflow? *)
1813        let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1814        let status = { status with sp = new_sp } in
1815        write_at_sp status (get_arg_8 status false a)
1816      | `POP (`DIRECT b) ->
1817        let contents = read_at_sp status in
1818        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1819        let status = { status with sp = new_sp } in
1820        let status = set_arg_8 status contents (`DIRECT b) in
1821        status
1822      | `XCH(`A, arg) ->
1823        let old_arg = get_arg_8 status false arg in
1824        let old_acc = status.acc in
1825        let status = set_arg_8 status old_acc arg in
1826        { status with acc = old_arg }
1827      | `XCHD(`A, i) ->
1828        let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1829        let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1830        let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1831        let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1832        let status = { status with acc = new_acc } in
1833        set_arg_8 status new_reg i
1834      (* program branching *)
1835      | `JC (`REL rel) ->
1836        if get_cy_flag status then
1837          let cry, new_pc = half_add status.pc (sign_extension rel) in
1838          { status with pc = new_pc }
1839        else
1840          status
1841      | `JNC (`REL rel) ->
1842        if not $ get_cy_flag status then
1843          let cry, new_pc = half_add status.pc (sign_extension rel) in
1844          { status with pc = new_pc }
1845        else
1846          status
1847      | `JB (b, (`REL rel)) ->
1848        if get_arg_1 status false b then
1849          let cry, new_pc = half_add status.pc (sign_extension rel) in
1850          { status with pc = new_pc }
1851        else
1852          status
1853      | `JNB (b, (`REL rel)) ->
1854        if not $ 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      | `JBC (b, (`REL rel)) ->
1860        let status = set_arg_1 status false b in
1861        if get_arg_1 status false b then
1862          let cry, new_pc = half_add status.pc (sign_extension rel) in
1863          { status with pc = new_pc }
1864        else
1865          status
1866      | `RET ->
1867        (* DPM: What happens when we underflow? *)
1868        let high_bits = read_at_sp status in
1869        let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1870        let status = { status with sp = new_sp } in
1871        let low_bits = read_at_sp status in
1872        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1873        let status = { status with sp = new_sp } in
1874        { status with pc = mk_word high_bits low_bits }
1875      | `RETI ->
1876        let high_bits = read_at_sp status in
1877        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1878        let status = { status with sp = new_sp } in
1879        let low_bits = read_at_sp status in
1880        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1881        let status = { status with sp = new_sp } in
1882        { status with pc = mk_word high_bits low_bits }
1883      | `ACALL (`ADDR11 a) ->
1884        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1885        let status = { status with sp = new_sp } in
1886        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1887        let status = write_at_sp status pc_lower_byte in
1888        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1889        let status = { status with sp = new_sp } in
1890        let status = write_at_sp status pc_upper_byte in
1891        let addr = addr16_of_addr11 status.pc a in
1892        { status with pc = addr }
1893      | `LCALL (`ADDR16 addr) ->
1894        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1895        let status = { status with sp = new_sp } in
1896        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1897        let status = write_at_sp status pc_lower_byte in
1898        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1899        let status = { status with sp = new_sp } in
1900        let status = write_at_sp status pc_upper_byte in
1901        { status with pc = addr }
1902      | `AJMP (`ADDR11 a) ->
1903        let addr = addr16_of_addr11 status.pc a in
1904        { status with pc = addr }
1905      | `LJMP (`ADDR16 a) ->
1906        { status with pc = a }
1907      | `SJMP (`REL rel) ->
1908        let cry, new_pc = half_add status.pc (sign_extension rel) in
1909        { status with pc = new_pc }
1910      | `JMP `IND_DPTR ->
1911        let dptr = mk_word status.dph status.dpl in
1912        let big_acc = mk_word (zero `Eight) status.acc in
1913        let cry, jmp_addr = half_add big_acc dptr in
1914        let cry, new_pc = half_add status.pc jmp_addr in
1915        { status with pc = new_pc }
1916      | `JZ (`REL rel) ->
1917        if status.acc = zero `Eight then
1918          let cry, new_pc = half_add status.pc (sign_extension rel) in
1919          { status with pc = new_pc }
1920        else
1921          status
1922      | `JNZ (`REL rel) ->
1923        if status.acc <> zero `Eight then
1924          let cry, new_pc = half_add status.pc (sign_extension rel) in
1925          { status with pc = new_pc }
1926        else
1927          status
1928      | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1929        let new_carry = status.acc < get_arg_8 status false ag in
1930        if get_arg_8 status false ag <> status.acc then
1931          let cry, new_pc = half_add status.pc (sign_extension rel) in
1932          let status = set_flags status new_carry None (get_ov_flag status) in
1933          { status with pc = new_pc;  }
1934        else
1935          set_flags status new_carry None (get_ov_flag status)
1936      | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1937        let new_carry = get_arg_8 status false ag < d in
1938        if get_arg_8 status false ag <> d then
1939          let cry, new_pc = half_add status.pc (sign_extension rel) in
1940          let status = { status with pc = new_pc } in
1941          set_flags status new_carry None (get_ov_flag status)
1942        else
1943          set_flags status new_carry None (get_ov_flag status)
1944      | `DJNZ (ag, (`REL rel)) ->
1945        let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1946        let status = set_arg_8 status new_ag ag in
1947        if new_ag <> zero `Eight then
1948          let cry, new_pc = half_add status.pc (sign_extension rel) in
1949          { status with pc = new_pc }
1950        else
1951          status
1952      | `NOP -> status) in
1953  let status = timers status ticks in
1954  let in_cont, `Out out_cont = status.io in
1955  let status = serial_port_input status in_cont in
1956  let status = serial_port_output status out_cont in
1957  let status = interrupts status in
1958  { status with previous_p1_val = get_bit status.p3 4;
1959    previous_p3_val = get_bit status.p3 5 }
1960;;
1961
1962(*
1963OLD output routine:
1964           (* Serial port output, part one *)
1965           let status =
1966             (match status.expected_out_time with
1967               `At t when status.clock >= t ->
1968                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1969              | _ -> status) in
1970
1971             (if status.expected_out_time = `Now then
1972               if get_bit status.scon 7 then
1973                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1974                   { status with expected_out_time = `At exp_time; io = new_cont }
1975               else
1976                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1977                   { status with expected_out_time = `At exp_time; io = new_cont }               
1978             else
1979               status) in
1980*)
1981
1982let rec execute f s =
1983  let cont =
1984    try f s; true
1985    with Halt -> false
1986  in
1987  if cont then execute f (execute1 s)
1988  else s
1989;;
1990
1991
1992let load_program p =
1993  let st = load p.ASM.code initialize in
1994  { st with exit_addr = p.ASM.exit_addr (* ; cost_labels = p.ASM.cost_labels *)}
1995
1996type cost_trace = {
1997  mutable ct_labels : CostLabel.t list;
1998  mutable ct_inds   : CostLabel.const_indexing list;
1999}
2000
2001(* FIXME: supposing only one index reset or increment per instruction *)
2002let update_indexes trace p st =
2003  try
2004    let i = BitVectors.WordMap.find st.pc p.ASM.inds in
2005    CostLabel.enter_loop trace.ct_inds i
2006  with Not_found -> ();
2007    try
2008      let i = BitVectors.WordMap.find st.pc p.ASM.incs in
2009      CostLabel.continue_loop trace.ct_inds i
2010    with Not_found -> ();
2011      let instr,_,_ = fetch st.code_memory st.pc in
2012      match instr with
2013        | `ACALL _ | `LCALL _ ->
2014          trace.ct_inds <- CostLabel.new_const_ind trace.ct_inds
2015        | `RET ->
2016          trace.ct_inds <- CostLabel.forget_const_ind trace.ct_inds
2017        | _ -> ()
2018
2019let update_labels trace p st =
2020  try
2021    let cost_label = BitVectors.WordMap.find st.pc p.cost_labels in
2022    let ind = CostLabel.curr_const_ind trace.ct_inds in
2023    let cost_label = CostLabel.ev_indexing ind cost_label in
2024    trace.ct_labels <- cost_label :: trace.ct_labels
2025  with Not_found -> ()
2026
2027
2028
2029let update_trace trace p st =
2030  update_labels trace p st;
2031  update_indexes trace p st;
2032  if st.pc = st.exit_addr (* <=> end of program *) then raise Halt else st
2033
2034let result st =
2035  let dpl = st.dpl in
2036  let dpr = st.dph in
2037  let addr i = BitVectors.vect_of_int i `Seven in
2038  let get_ireg i = Physical.Byte7Map.find (addr i) st.low_internal_ram in
2039  let r00 = get_ireg 0 in
2040  let r01 = get_ireg 1 in
2041  let is = [dpl ; dpr ; r00 ; r01] in
2042  let f i = IntValue.Int32.of_int (BitVectors.int_of_vect i) in
2043  IntValue.Int32.merge (List.map f is)
2044
2045let interpret debug p =
2046  Printf.printf "*** 8051 interpret ***\n%!" ;
2047  if p.ASM.has_main then
2048    let st = load_program p in
2049    let trace = {ct_labels = []; ct_inds = []} in
2050    let callback = update_trace trace p in
2051    let st = execute callback st in
2052    let res = result st in
2053    if debug then
2054      Printf.printf "Result = %s\n%!" (IntValue.Int32.to_string res) ;
2055    (res, List.rev trace.ct_labels)
2056  else (IntValue.Int32.zero, [])
2057
2058
2059let size_of_instr instr =
2060  let exit_lbl = "exit" in
2061  let p = { ASM.ppreamble = [] ; ASM.pexit_label = exit_lbl ;
2062            ASM.pcode = [instr ; `Label exit_lbl] ; ASM.phas_main = false } in
2063  let p = assembly p in
2064  let status = load_program p in
2065  let addr_zero = BitVectors.vect_of_int 0 `Sixteen in
2066  let (_, size, _) = fetch status.code_memory addr_zero in
2067  BitVectors.int_of_vect size
2068
2069let size_of_instrs instrs =
2070  let f res instr = res + (size_of_instr instr) in
2071  List.fold_left f 0 instrs
Note: See TracBrowser for help on using the repository browser.