source: Deliverables/D4.1/ASMInterpret.ml

Last change on this file was 1708, checked in by mulligan, 8 years ago

Change to the execution of the MOVC instruction

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