source: Deliverables/D4.1/ASMInterpret.ml @ 557

Last change on this file since 557 was 557, checked in by mulligan, 9 years ago

Emulator fixed for Wilmer

File size: 75.7 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   | _,_ -> assert false
687;;
688
689let assembly1 =
690 function
691    `ACALL (`ADDR11 w) ->
692      let (a10,a9,a8,b1) = from_word11 w in
693        [mk_byte_from_bits ((a10,a9,a8,true),(false,false,false,true)); b1]
694  | `ADD (`A,`REG (r1,r2,r3)) ->
695     [mk_byte_from_bits ((false,false,true,false),(true,r1,r2,r3))]
696  | `ADD (`A, `DIRECT b1) ->
697     [mk_byte_from_bits ((false,false,true,false),(false,true,false,true)); b1]
698  | `ADD (`A, `INDIRECT i1) ->
699     [mk_byte_from_bits ((false,false,true,false),(false,true,true,i1))]
700  | `ADD (`A, `DATA b1) ->
701     [mk_byte_from_bits ((false,false,true,false),(false,true,false,false)); b1]
702  | `ADDC (`A, `REG(r1,r2,r3)) ->
703     [mk_byte_from_bits ((false,false,true,true),(true,r1,r2,r3))]
704  | `ADDC (`A, `DIRECT b1) ->
705     [mk_byte_from_bits ((false,false,true,true),(false,true,false,true)); b1]
706  | `ADDC (`A,`INDIRECT i1) ->
707     [mk_byte_from_bits ((false,false,true,true),(false,true,true,i1))]
708  | `ADDC (`A,`DATA b1) ->
709     [mk_byte_from_bits ((false,false,true,true),(false,true,false,false)); b1]
710  | `AJMP (`ADDR11 w) ->
711     let (a10,a9,a8,b1) = from_word11 w in
712       [mk_byte_from_bits ((a10,a9,a8,false),(false,false,false,true)); b1]
713  | `ANL (`U1 (`A, `REG (r1,r2,r3))) ->
714     [mk_byte_from_bits ((false,true,false,true),(true,r1,r2,r3))]
715  | `ANL (`U1 (`A, `DIRECT b1)) ->
716     [mk_byte_from_bits ((false,true,false,true),(false,true,false,true)); b1]
717  | `ANL (`U1 (`A, `INDIRECT i1)) ->
718     [mk_byte_from_bits ((false,true,false,true),(false,true,true,i1))]
719  | `ANL (`U1 (`A, `DATA b1)) ->
720     [mk_byte_from_bits ((false,true,false,true),(false,true,false,false)); b1]
721  | `ANL (`U2 (`DIRECT b1,`A)) ->
722     [mk_byte_from_bits ((false,true,false,true),(false,false,true,false)); b1]
723  | `ANL (`U2 (`DIRECT b1,`DATA b2)) ->
724     [mk_byte_from_bits ((false,true,false,true),(false,false,true,true)); b1; b2]
725  | `ANL (`U3 (`C,`BIT b1)) ->
726     [mk_byte_from_bits ((true,false,false,false),(false,false,true,false)); b1]
727  | `ANL (`U3 (`C,`NBIT b1)) ->
728    [mk_byte_from_bits ((true,false,true,true),(false,false,false,false)); b1]
729  | `CJNE (`U1 (`A, `DIRECT b1), `REL b2) ->
730    [mk_byte_from_bits ((true,false,true,true),(false,true,false,true)); b1; b2]
731  | `CJNE (`U1 (`A, `DATA b1), `REL b2) ->
732    [mk_byte_from_bits ((true,false,true,true),(false,true,false,false)); b1; b2]
733  | `CJNE (`U2 (`REG(r1,r2,r3), `DATA b1), `REL b2) ->
734    [mk_byte_from_bits ((true,false,true,true),(true,r1,r2,r3)); b1; b2]
735  | `CJNE (`U2 (`INDIRECT i1, `DATA b1), `REL b2) ->
736    [mk_byte_from_bits ((true,false,true,true),(false,true,true,i1)); b1; b2]
737  | `CLR `A ->
738    [mk_byte_from_bits ((true,true,true,false),(false,true,false,false))]
739  | `CLR `C ->
740    [mk_byte_from_bits ((true,true,false,false),(false,false,true,true))]
741  | `CLR (`BIT b1) ->
742    [mk_byte_from_bits ((true,true,false,false),(false,false,true,false)); b1]
743  | `CPL `A ->
744    [mk_byte_from_bits ((true,true,true,true),(false,true,false,false))]
745  | `CPL `C ->
746    [mk_byte_from_bits ((true,false,true,true),(false,false,true,true))]
747  | `CPL (`BIT b1) ->
748    [mk_byte_from_bits ((true,false,true,true),(false,false,true,false)); b1]
749  | `DA `A ->
750    [mk_byte_from_bits ((true,true,false,true),(false,true,false,false))]
751  | `DEC `A ->
752    [mk_byte_from_bits ((false,false,false,true),(false,true,false,false))]
753  | `DEC (`REG(r1,r2,r3)) ->
754    [mk_byte_from_bits ((false,false,false,true),(true,r1,r2,r3))]
755  | `DEC (`DIRECT b1) ->
756    [mk_byte_from_bits ((false,false,false,true),(false,true,false,true)); b1]
757  | `DEC (`INDIRECT i1) ->
758    [mk_byte_from_bits ((false,false,false,true),(false,true,true,i1))]
759  | `DIV (`A, `B) ->
760    [mk_byte_from_bits ((true,false,false,false),(false,true,false,false))]
761  | `DJNZ (`REG(r1,r2,r3), `REL b1) ->
762    [mk_byte_from_bits ((true,true,false,true),(true,r1,r2,r3)); b1]
763  | `DJNZ (`DIRECT b1, `REL b2) ->
764    [mk_byte_from_bits ((true,true,false,true),(false,true,false,true)); b1; b2]
765  | `INC `A ->
766    [mk_byte_from_bits ((false,false,false,false),(false,true,false,false))]
767  | `INC (`REG(r1,r2,r3)) ->
768    [mk_byte_from_bits ((false,false,false,false),(true,r1,r2,r3))]
769  | `INC (`DIRECT b1) ->
770    [mk_byte_from_bits ((false,false,false,false),(false,true,false,true)); b1]
771  | `INC (`INDIRECT i1) ->
772    [mk_byte_from_bits ((false,false,false,false),(false,true,true,i1))]
773  | `INC `DPTR ->
774    [mk_byte_from_bits ((true,false,true,false),(false,false,true,true))]
775  | `JB (`BIT b1, `REL b2) ->
776    [mk_byte_from_bits ((false,false,true,false),(false,false,false,false)); b1; b2]
777  | `JBC (`BIT b1, `REL b2) ->
778    [mk_byte_from_bits ((false,false,false,true),(false,false,false,false)); b1; b2]
779  | `JC (`REL b1) ->
780    [mk_byte_from_bits ((false,true,false,false),(false,false,false,false)); b1]
781  | `JMP `IND_DPTR ->
782    [mk_byte_from_bits ((false,true,true,true),(false,false,true,true))]
783  | `JNB (`BIT b1, `REL b2) ->
784    [mk_byte_from_bits ((false,false,true,true),(false,false,false,false)); b1; b2]
785  | `JNC (`REL b1) ->
786    [mk_byte_from_bits ((false,true,false,true),(false,false,false,false)); b1]
787  | `JNZ (`REL b1) ->
788    [mk_byte_from_bits ((false,true,true,true),(false,false,false,false)); b1]
789  | `JZ (`REL b1) ->
790    [mk_byte_from_bits ((false,true,true,false),(false,false,false,false)); b1]
791  | `LCALL (`ADDR16 w) ->
792      let (b1,b2) = from_word w in
793        [mk_byte_from_bits ((false,false,false,true),(false,false,true,false)); b1; b2]
794  | `LJMP (`ADDR16 w) ->
795      let (b1,b2) = from_word w in
796        [mk_byte_from_bits ((false,false,false,false),(false,false,true,false)); b1; b2]
797  | `MOV (`U1 (`A, `REG(r1,r2,r3))) ->
798    [mk_byte_from_bits ((true,true,true,false),(true,r1,r2,r3))]
799  | `MOV (`U1 (`A, `DIRECT b1)) ->
800    [mk_byte_from_bits ((true,true,true,false),(false,true,false,true)); b1]
801  | `MOV (`U1 (`A, `INDIRECT i1)) ->
802    [mk_byte_from_bits ((true,true,true,false),(false,true,true,i1))]
803  | `MOV (`U1 (`A, `DATA b1)) ->
804    [mk_byte_from_bits ((false,true,true,true),(false,true,false,false)); b1]
805  | `MOV (`U2 (`REG(r1,r2,r3), `A)) ->
806    [mk_byte_from_bits ((true,true,true,true),(true,r1,r2,r3))]
807  | `MOV (`U2 (`REG(r1,r2,r3), (`DIRECT b1))) ->
808    [mk_byte_from_bits ((true,false,true,false),(true,r1,r2,r3)); b1]
809  | `MOV (`U2 (`REG(r1,r2,r3), (`DATA b1))) ->
810    [mk_byte_from_bits ((false,true,true,true),(true,r1,r2,r3)); b1]
811  | `MOV (`U3 (`DIRECT b1, `A)) ->
812    [mk_byte_from_bits ((true,true,true,true),(false,true,false,true)); b1]
813  | `MOV (`U3 (`DIRECT b1, `REG(r1,r2,r3))) ->
814    [mk_byte_from_bits ((true,false,false,false),(true,r1,r2,r3)); b1]
815  | `MOV (`U3 (`DIRECT b1, `DIRECT b2)) ->
816    [mk_byte_from_bits ((true,false,false,false),(false,true,false,true)); b1; b2]
817  | `MOV (`U3 (`DIRECT b1, `INDIRECT i1)) ->
818    [mk_byte_from_bits ((true,false,false,false),(false,true,true,i1)); b1]
819  | `MOV (`U3 (`DIRECT b1, `DATA b2)) ->
820    [mk_byte_from_bits ((false,true,true,true),(false,true,false,true)); b1; b2]
821  | `MOV (`U2 (`INDIRECT i1, `A)) ->
822    [mk_byte_from_bits ((true,true,true,true),(false,true,true,i1))]
823  | `MOV (`U2 (`INDIRECT i1, `DIRECT b1)) ->
824    [mk_byte_from_bits ((true,false,true,false),(false,true,true,i1)); b1]
825  | `MOV (`U2 (`INDIRECT i1, `DATA b1)) ->
826    [mk_byte_from_bits ((false,true,true,true),(false,true,true,i1)); b1]
827  | `MOV (`U5 (`C, `BIT b1)) ->
828    [mk_byte_from_bits ((true,false,true,false),(false,false,true,false)); b1]
829  | `MOV (`U6 (`BIT b1, `C)) ->
830    [mk_byte_from_bits ((true,false,false,true),(false,false,true,false)); b1]
831  | `MOV (`U4 (`DPTR, `DATA16 w)) ->
832    let (b1,b2) = from_word w in
833      [mk_byte_from_bits ((true,false,false,true),(false,false,false,false)); b1; b2]
834  | `MOVC (`A, `A_DPTR) ->
835    [mk_byte_from_bits ((true,false,false,true),(false,false,true,true))]
836  | `MOVC (`A, `A_PC) ->
837    [mk_byte_from_bits ((true,false,false,false),(false,false,true,true))]
838  | `MOVX (`U1 (`A, `EXT_INDIRECT i1)) ->
839    [mk_byte_from_bits ((true,true,true,false),(false,false,true,i1))]
840  | `MOVX (`U1 (`A, `EXT_IND_DPTR)) ->
841    [mk_byte_from_bits ((true,true,true,false),(false,false,false,false))]
842  | `MOVX (`U2 (`EXT_INDIRECT i1, `A)) ->
843    [mk_byte_from_bits ((true,true,true,true),(false,false,true,i1))]
844  | `MOVX (`U2 (`EXT_IND_DPTR, `A)) ->
845    [mk_byte_from_bits ((true,true,true,true),(false,false,false,false))]
846  | `MUL(`A, `B) ->
847    [mk_byte_from_bits ((true,false,true,false),(false,true,false,false))]
848  | `NOP ->
849    [mk_byte_from_bits ((false,false,false,false),(false,false,false,false))]
850  | `ORL (`U1(`A, `REG(r1,r2,r3))) ->
851    [mk_byte_from_bits ((false,true,false,false),(true,r1,r2,r3))]
852  | `ORL (`U1(`A, `DIRECT b1)) ->
853    [mk_byte_from_bits ((false,true,false,false),(false,true,false,true)); b1]
854  | `ORL (`U1(`A, `INDIRECT i1)) ->
855    [mk_byte_from_bits ((false,true,false,false),(false,true,true,i1))]
856  | `ORL (`U1(`A, `DATA b1)) ->
857    [mk_byte_from_bits ((false,true,false,false),(false,true,false,false)); b1]
858  | `ORL (`U2(`DIRECT b1, `A)) ->
859    [mk_byte_from_bits ((false,true,false,false),(false,false,true,false)); b1]
860  | `ORL (`U2 (`DIRECT b1, `DATA b2)) ->
861    [mk_byte_from_bits ((false,true,false,false),(false,false,true,true)); b1; b2]
862  | `ORL (`U3 (`C, `BIT b1)) ->
863    [mk_byte_from_bits ((false,true,true,true),(false,false,true,false)); b1]
864  | `ORL (`U3 (`C, `NBIT b1)) ->
865    [mk_byte_from_bits ((true,false,true,false),(false,false,false,false)); b1]
866  | `POP (`DIRECT b1) ->
867    [mk_byte_from_bits ((true,true,false,true),(false,false,false,false)); b1]
868  | `PUSH (`DIRECT b1) ->
869    [mk_byte_from_bits ((true,true,false,false),(false,false,false,false)); b1]
870  | `RET ->
871    [mk_byte_from_bits ((false,false,true,false),(false,false,true,false))]
872  | `RETI ->
873    [mk_byte_from_bits ((false,false,true,true),(false,false,true,false))]
874  | `RL `A ->
875    [mk_byte_from_bits ((false,false,true,false),(false,false,true,true))]
876  | `RLC `A ->
877    [mk_byte_from_bits ((false,false,true,true),(false,false,true,true))]
878  | `RR `A ->
879    [mk_byte_from_bits ((false,false,false,false),(false,false,true,true))]
880  | `RRC `A ->
881    [mk_byte_from_bits ((false,false,false,true),(false,false,true,true))]
882  | `SETB `C ->
883    [mk_byte_from_bits ((true,true,false,true),(false,false,true,true))]
884  | `SETB (`BIT b1) ->
885    [mk_byte_from_bits ((true,true,false,true),(false,false,true,false)); b1]
886  | `SJMP (`REL b1) ->
887    [mk_byte_from_bits ((true,false,false,false),(false,false,false,false)); b1]
888  | `SUBB (`A, `REG(r1,r2,r3)) ->
889    [mk_byte_from_bits ((true,false,false,true),(true,r1,r2,r3))]
890  | `SUBB (`A, `DIRECT b1) ->
891    [mk_byte_from_bits ((true,false,false,true),(false,true,false,true)); b1]
892  | `SUBB (`A, `INDIRECT i1) ->
893    [mk_byte_from_bits ((true,false,false,true),(false,true,true,i1))]
894  | `SUBB (`A, `DATA b1) ->
895    [mk_byte_from_bits ((true,false,false,true),(false,true,false,false)); b1]
896  | `SWAP `A ->
897    [mk_byte_from_bits ((true,true,false,false),(false,true,false,false))]
898  | `XCH (`A, `REG(r1,r2,r3)) ->
899    [mk_byte_from_bits ((true,true,false,false),(true,r1,r2,r3))]
900  | `XCH (`A, `DIRECT b1) ->
901    [mk_byte_from_bits ((true,true,false,false),(false,true,false,true)); b1]
902  | `XCH (`A, `INDIRECT i1) ->
903    [mk_byte_from_bits ((true,true,false,false),(false,true,true,i1))]
904  | `XCHD(`A, `INDIRECT i1) ->
905    [mk_byte_from_bits ((true,true,false,true),(false,true,true,i1))]
906  | `XRL(`U1(`A, `REG(r1,r2,r3))) ->
907    [mk_byte_from_bits ((false,true,true,false),(true,r1,r2,r3))]
908  | `XRL(`U1(`A, `DIRECT b1)) ->
909    [mk_byte_from_bits ((false,true,true,false),(false,true,false,true)); b1]
910  | `XRL(`U1(`A, `INDIRECT i1)) ->
911    [mk_byte_from_bits ((false,true,true,false),(false,true,true,i1))]
912  | `XRL(`U1(`A, `DATA b1)) ->
913    [mk_byte_from_bits ((false,true,true,false),(false,true,false,false)); b1]
914  | `XRL(`U2(`DIRECT b1, `A)) ->
915    [mk_byte_from_bits ((false,true,true,false),(false,false,true,false)); b1]
916  | `XRL(`U2(`DIRECT b1, `DATA b2)) ->
917    [mk_byte_from_bits ((false,true,true,false),(false,false,true,true)); b1; b2]
918;;
919
920let load_code_memory = Util.fold_lefti (fun i mem v -> Physical.WordMap.add (vect_of_int i `Sixteen) v mem) Physical.WordMap.empty
921
922let load_mem mem status = { status with code_memory = mem }
923let load l = load_mem (load_code_memory l)
924
925module StringMap = Map.Make(String);;
926module WordMap = Map.Make(struct type t = BitVectors.word let compare = compare end);;
927
928type labelled_memory = BitVectors.byte list * string WordMap.t * bool (* has main *)
929
930let assembly_jump addr_of =
931 function
932    `JC a1 -> `JC (addr_of a1)
933  | `JNC a1 -> `JNC (addr_of a1)
934  | `JB (a1,a2) -> `JB (a1,addr_of a2)
935  | `JNB (a1,a2) -> `JNB (a1,addr_of a2)
936  | `JBC (a1,a2) -> `JBC (a1,addr_of a2)
937  | `JZ a1 -> `JZ (addr_of a1)
938  | `JNZ a1 -> `JNZ (addr_of a1)
939  | `CJNE (a1,a2) -> `CJNE (a1,addr_of a2)
940  | `DJNZ (a1,a2) -> `DJNZ (a1,addr_of a2)
941;;
942
943let assembly p =
944 let datalabels,_ =
945  List.fold_left
946   (fun (datalabels,addr) (name,size) ->
947     let addr16 = vect_of_int addr `Sixteen in
948      StringMap.add name addr16 datalabels, addr+size
949   ) (StringMap.empty,0) p.ASM.preamble
950 in
951 let pc,labels,costs =
952  List.fold_left
953   (fun (pc,labels,costs) i ->
954     match i with
955        `Label s -> pc, StringMap.add s pc labels, costs
956      | `Cost s -> pc, labels, WordMap.add pc s costs
957      | `Mov (_,_) -> pc, labels, costs
958      | `Jmp _ 
959      | `Call _ -> (snd (half_add pc (BitVectors.vect_of_int 3 `Sixteen))), labels, costs  (*CSC: very stupid: always expand to worst opcode *)
960      | `WithLabel i ->
961          let fake_addr _ = `REL (zero `Eight) in
962          let fake_jump = assembly_jump fake_addr i in
963          let i',pc',_ = fetch (load_code_memory (assembly1 fake_jump)) (vect_of_int 0 `Sixteen) in
964           assert (fake_jump = i');
965           (snd (half_add pc pc'),labels, costs)
966      | #instruction as i ->
967        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
968         assert (i = i');
969         (snd (half_add pc pc'),labels, costs)
970   ) (BitVectors.zero `Sixteen,StringMap.empty,WordMap.empty) p.ASM.code
971 in
972  List.flatten (List.map
973     (function
974        `Label _
975      | `Cost _ -> []
976      | `WithLabel i ->
977          let addr_of (`Label s) =
978           let addr = StringMap.find s labels in
979            (* NOT IMPLEMENTED YET; NEEDS SMART ALGORITHM *)
980            `REL (assert false) (*addr*)
981          in
982           assembly1 (assembly_jump addr_of i)
983      | `Mov (`DPTR,s) ->
984          let addrr16 = StringMap.find s datalabels in
985           assembly1 (`MOV (`U4 (`DPTR,`DATA16 addrr16)))
986      | `Jmp s ->
987          let pc_offset = StringMap.find s labels in
988            assembly1 (`LJMP (`ADDR16 pc_offset))
989      | `Call s ->
990          let pc_offset = StringMap.find s labels in
991            assembly1 (`LCALL (`ADDR16 pc_offset ))
992      | #instruction as i -> assembly1 i) p.ASM.code), costs, p.ASM.has_main
993;;
994
995let set_register status v reg =
996  let addr = get_address_of_register status reg in
997    { status with low_internal_ram =
998        Byte7Map.add addr v status.low_internal_ram }
999;;
1000
1001let get_arg_8 status from_latch = 
1002 function
1003    `DIRECT addr ->
1004       let n0, n1 = from_byte addr in
1005       (match from_nibble n0 with
1006          (false,r1,r2,r3) ->
1007            Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
1008        | _ -> get_sfr status addr from_latch)
1009  | `INDIRECT b ->
1010       let (b1, b2) = from_byte (get_register status (false,false,b)) in
1011         (match (from_nibble b1, b2) with 
1012           (false,r1,r2,r3),b2 ->
1013             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.low_internal_ram
1014         | (true,r1,r2,r3),b2 ->
1015             Byte7Map.find (mk_byte7 r1 r2 r3 b2) status.high_internal_ram)
1016  | `REG (b1,b2,b3) -> get_register status (b1,b2,b3)
1017  | `A -> status.acc
1018  | `B -> status.b
1019  | `DATA b -> b
1020  | `A_DPTR ->
1021       let dpr = mk_word status.dph status.dpl in
1022       (* CSC: what is the right behaviour in case of overflow?
1023          assert false for now. Try to understand what DEC really does *)
1024       let cry,addr = half_add dpr (mk_word (vect_of_int 0 `Eight) status.acc) in
1025         Physical.WordMap.find addr status.external_ram
1026  | `A_PC ->
1027       (* CSC: what is the right behaviour in case of overflow?
1028          assert false for now *)
1029       let cry,addr = half_add status.pc (mk_word (vect_of_int 0 `Eight) status.acc) in
1030         Physical.WordMap.find addr status.external_ram
1031  | `EXT_INDIRECT b ->
1032         let addr = get_register status (false,false,b) in
1033           Physical.WordMap.find (mk_word (zero `Eight) addr) status.external_ram
1034  | `EXT_IND_DPTR ->
1035       let dpr = mk_word status.dph status.dpl in
1036         Physical.WordMap.find dpr status.external_ram
1037;;
1038
1039let get_arg_16 _status = function `DATA16 w -> w
1040
1041let get_arg_1 status from_latch =
1042  function
1043    `BIT addr
1044  | `NBIT addr as x ->
1045     let n1, n2 = from_byte addr in
1046     let res =
1047      (match from_nibble n1 with
1048         (false,r1,r2,r3) ->
1049           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1050           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1051             get_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8)
1052        | (true,r1,r2,r3) ->
1053            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1054            let div = addr / 8 in
1055            let rem = addr mod 8 in
1056              get_bit (get_sfr status (vect_of_int ((div * 8) + 128) `Eight) from_latch) rem)
1057    in (match x with `NBIT _ -> not res | _ -> res)
1058  | `C -> get_cy_flag status
1059
1060let set_arg_1 status v =
1061  function
1062    `BIT addr ->
1063      let n1, n2 = from_byte addr in
1064      (match from_nibble n1 with
1065         (false,r1,r2,r3) ->
1066           let addr = (int_of_vect (mk_byte7 r1 r2 r3 n2)) in
1067           let addr' = vect_of_int ((addr / 8) + 32) `Seven in
1068           let n_bit = set_bit (Byte7Map.find addr' status.low_internal_ram) (addr mod 8) v in
1069             { status with low_internal_ram = Byte7Map.add addr' n_bit status.low_internal_ram }
1070      | (true,r1,r2,r3) ->
1071            let addr = int_of_vect $ mk_byte7 r1 r2 r3 n2 in
1072            let div = addr / 8 in
1073            let rem = addr mod 8 in
1074            let addr' = vect_of_int ((div * 8) + 128) `Eight in
1075            let sfr = get_sfr status addr' true in (* are we reading from the latch here? *)
1076            let sfr' = set_bit sfr rem v in
1077              set_sfr status addr' sfr')
1078    | `C ->
1079       let (n1,n2) = from_byte status.psw in
1080       let (_,b2,b3,b4) = from_nibble n1 in
1081         { status with psw = (mk_byte (mk_nibble v b2 b3 b4) n2) }
1082
1083let set_arg_8 status v =
1084  function
1085  `DIRECT addr ->
1086    let (b1, b2) = from_byte addr in
1087    (match from_nibble b1 with
1088        (false,r1,r2,r3) ->
1089          { status with low_internal_ram =
1090              Byte7Map.add (mk_byte7 r1 r2 r3 b2) v status.low_internal_ram }
1091      | _ -> set_sfr status addr v)
1092    | `INDIRECT b ->
1093      let (b1, b2) = from_byte (get_register status (false,false,b)) in
1094      (match (from_nibble b1, b2) with 
1095          (false,r1,r2,r3),n1 ->
1096            { status with low_internal_ram =
1097                Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.low_internal_ram }
1098        | (true,r1,r2,r3),n1 ->
1099          { status with high_internal_ram =
1100              Byte7Map.add (mk_byte7 r1 r2 r3 n1) v status.high_internal_ram })
1101    | `REG (b1,b2,b3) ->
1102      set_register status v (b1,b2,b3)
1103    | `A -> { status with acc = v }
1104    | `B -> { status with b = v }
1105    | `EXT_IND_DPTR ->
1106      let dpr = mk_word status.dph status.dpl in
1107      { status with external_ram =
1108          Physical.WordMap.add dpr v status.external_ram }
1109    | `EXT_INDIRECT b ->
1110      let addr = get_register status (false,false,b) in
1111      { status with external_ram =
1112          Physical.WordMap.add (mk_word (zero `Eight) addr) v status.external_ram }
1113;;
1114
1115let set_arg_16 status wrd =
1116  function
1117  `DPTR ->
1118    let (dh, dl) = from_word wrd in
1119    { status with dph = dh; dpl = dl }
1120     
1121let set_flags status c ac ov =
1122  { status with psw =
1123      let bu,bl = from_byte status.psw in
1124      let (_c,oac,fo,rs1),(rs0,_ov,ud,p) = from_nibble bu, from_nibble bl in
1125      let ac = match ac with None -> oac | Some v -> v in
1126      mk_byte (mk_nibble c ac fo rs1) (mk_nibble rs0 ov ud p)
1127  }
1128;;
1129
1130let xor b1 b2 =
1131  if b1 = true && b2 = true then
1132    false
1133  else if b1 = false && b2 = false then
1134    false
1135  else true
1136;;
1137
1138let read_at_sp status =
1139  let n1,n2 = from_byte status.sp in
1140  let m,r1,r2,r3 = from_nibble n1 in
1141  Byte7Map.find (mk_byte7 r1 r2 r3 n2)
1142    (if m then status.low_internal_ram else status.high_internal_ram)
1143;;
1144
1145let write_at_sp status v =
1146  let n1,n2 = from_byte status.sp in
1147  match from_nibble n1 with
1148      true,r1,r2,r3 ->
1149        let memory =
1150          Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.low_internal_ram
1151        in
1152        { status with low_internal_ram = memory }
1153    | false,r1,r2,r3 ->
1154      let memory =
1155        Byte7Map.add (mk_byte7 r1 r2 r3 n2) v status.high_internal_ram
1156      in
1157      { status with high_internal_ram = memory }
1158;;
1159
1160let timer0 status b1 b2 ticks =
1161  let b = get_bit status.tcon 4 in
1162          (* Timer0 first *)
1163  (match b1,b2 with
1164      true,true ->
1165              (* Archaic 13 bit mode. *)
1166        if b then
1167          let res,_,_,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1168          let res = int_of_vect res in
1169          if res > 31 then
1170            let res = res mod 32 in
1171            let res',cy',ov',ac' = add8_with_c status.th0 (vect_of_int 1 `Eight) false in
1172            if ov' then
1173              let b = set_bit status.tcon 7 true in
1174              { status with tcon = b; th0 = res'; tl0 = vect_of_int res `Eight }
1175            else
1176              { status with th0 = res'; tl0 = vect_of_int res `Eight }
1177          else
1178            { status with tl0 = vect_of_int res `Eight }
1179        else
1180          status
1181    | false,false ->
1182              (* 8 bit split timer mode. *)
1183      let status = 
1184        (if b then
1185            let res,cy,ov,ac = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1186            if ov then
1187              let b = set_bit status.tcon 5 true in
1188              { status with tcon = b; tl0 = res }
1189            else
1190              { status with tl0 = res }
1191         else
1192            status)
1193      in
1194      if get_bit status.tcon 6 then
1195        let res,cy,ov,ac = add8_with_c status.th0 (vect_of_int ticks `Eight) false in
1196        if ov then
1197          let b = set_bit status.tcon 7 true in
1198          { status with tcon = b; th0 = res }
1199        else
1200          { status with th0 = res }
1201      else
1202        status
1203    | false,true ->
1204             (* 16 bit timer mode. *)
1205      if b then
1206        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl0) (vect_of_int ticks `Sixteen) false in
1207                if ov then
1208                  let b = set_bit status.tcon 5 true in
1209                  let new_th0,new_tl0 = from_word res in
1210                  { status with tcon = b; th0 = new_th0; tl0 = new_tl0 }
1211                else
1212                  let new_th0,new_tl0 = from_word res in
1213                  { status with th0 = new_th0; tl0 = new_tl0 }
1214      else
1215        status
1216    | true,false ->
1217              (* 8 bit single timer mode. *)
1218      if b then
1219        let res,_,ov,_ = add8_with_c status.tl0 (vect_of_int ticks `Eight) false in
1220        if ov then
1221          let b = set_bit status.tcon 5 true in
1222          { status with tcon = b; tl0 = status.th0; }
1223        else
1224          { status with tl0 = res }
1225      else
1226        status)
1227   
1228let timer1 status b3 b4 ticks =
1229  let b = get_bit status.tcon 4 in
1230  (match b3,b4 with
1231      true,true ->
1232        (* Archaic 13 bit mode. *)
1233        if b then
1234          let res,_,_,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1235          let res = int_of_vect res in
1236          if res > 31 then
1237            let res = res mod 32 in
1238            let res',cy',ov',ac' = add8_with_c status.th1 (vect_of_int 1 `Eight) false in
1239            if ov' then
1240              let b = set_bit status.tcon 7 true in
1241              { status with tcon = b; th1 = res'; tl1 = vect_of_int res `Eight }
1242            else
1243              { status with th1 = res'; tl0 = vect_of_int res `Eight }
1244          else
1245            { status with tl1 = vect_of_int res `Eight }
1246        else
1247          status
1248    | false,false ->
1249              (* 8 bit split timer mode. *)
1250      let status = 
1251        (if b then
1252            let res,cy,ov,ac = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1253            if ov then
1254              let b = set_bit status.tcon 5 true in
1255                        { status with tcon = b; tl1 = res }
1256            else
1257              { status with tl1 = res }
1258         else
1259            status)
1260      in
1261      if get_bit status.tcon 6 then
1262        let res,cy,ov,ac = add8_with_c status.th1 (vect_of_int ticks `Eight) false in
1263        if ov then
1264          let b = set_bit status.tcon 7 true in
1265          { status with tcon = b; th1 = res }
1266        else
1267          { status with th1 = res }
1268      else
1269        status
1270    | false,true ->
1271             (* 16 bit timer mode. *)
1272      if b then
1273        let res,_,ov,_ = add16_with_c (mk_word status.th0 status.tl1) (vect_of_int ticks `Sixteen) false in
1274        if ov then
1275          let b = set_bit status.tcon 5 true in
1276          let new_th1,new_tl1 = from_word res in
1277          { status with tcon = b; th1 = new_th1; tl1 = new_tl1 }
1278        else
1279          let new_th1,new_tl1 = from_word res in
1280          { status with th1 = new_th1; tl1 = new_tl1 }
1281      else
1282        status
1283    | true,false ->
1284              (* 8 bit single timer mode. *)
1285      if b then
1286        let res,_,ov,_ = add8_with_c status.tl1 (vect_of_int ticks `Eight) false in
1287        if ov then
1288          let b = set_bit status.tcon 5 true in
1289          { status with tcon = b; tl1 = status.th1; }
1290        else
1291          { status with tl1 = res }
1292      else
1293        status)
1294;;
1295
1296let timers status ticks =
1297  (* DPM: Clock/Timer code follows. *)
1298  match bits_of_byte status.tmod with
1299    | (g1,c1,b1,b2),(g0,c0,b3,b4) ->
1300      let status =
1301        (if g0 then
1302            if get_bit status.p3 2 then
1303              if c0 then
1304                if status.previous_p1_val && not $ get_bit status.p3 4 then
1305                  timer0 status b1 b2 ticks
1306                else
1307                  status
1308              else
1309                timer0 status b1 b2 ticks
1310            else
1311              status
1312         else
1313            timer0 status b1 b2 ticks) in
1314      (* Timer 1 follows. *)
1315      let status =
1316        (if g1 then
1317            if get_bit status.p1 3 then
1318              if c1 then
1319                if status.previous_p3_val && not $ get_bit status.p3 5 then
1320                  timer1 status b3 b4 ticks
1321                else
1322                  status
1323              else
1324                timer1 status b3 b4 ticks
1325            else
1326              status
1327         else
1328            timer1 status b3 b4 ticks) in
1329      (* Timer 2 follows *)
1330      let status =
1331        (let (tf2,exf2,rclk,tclk),(exen2,tr2,ct2,cp2) = bits_of_byte status.t2con in
1332          (* Timer2 is enabled *)
1333         if tr2 then
1334            (* Counter/interval mode *)
1335           if ct2 && not cp2 then
1336             let word = mk_word status.th2 status.tl2 in
1337             let res,_,ov,_ = add16_with_c word (vect_of_int ticks `Sixteen) false in
1338             if ov then
1339               let new_th2 = status.rcap2h in
1340               let new_tl2 = status.rcap2l in
1341                  (* Overflow flag not set if either of the following flags are set *)
1342               if not rclk && not tclk then
1343                 let b = set_bit status.t2con 7 true in
1344                 { status with t2con = b;
1345                   th2 = new_th2;
1346                   tl2 = new_tl2 }
1347               else
1348                 { status with th2 = new_th2;
1349                   tl2 = new_tl2 }
1350             else
1351                (* Reload also signalled when a 1-0 transition is detected *)
1352               if status.previous_p1_val && not $ get_bit status.p1 1 then
1353                  (* In which case signal reload by setting T2CON.6 *)
1354                 let b = set_bit status.t2con 6 true in
1355                 { status with th2 = status.rcap2h;
1356                   tl2 = status.rcap2l;
1357                   t2con = b }
1358               else
1359                 let new_th2, new_tl2 = from_word res in
1360                 { status with th2 = new_th2;
1361                   tl2 = new_tl2 }
1362            (* Capture mode *)
1363           else if cp2 && exen2 then
1364              (* 1-0 transition detected *)
1365              (* DPM: look at this: is the timer still running throughout? *)
1366             if status.previous_p1_val && not $ get_bit status.p1 1 then
1367               status (* Implement clock here *)
1368             else
1369               status (* Implement clock here *)
1370           else
1371             status
1372           else
1373             status) in status
1374                     
1375;;
1376
1377let serial_port_input status in_cont =
1378      (* Serial port input *)
1379  match in_cont with
1380      Some (`In(time, line, epsilon, cont)) when get_bit status.scon 4 ->
1381        (let status =
1382           (match line with
1383               `P1 b ->
1384                 if status.clock >= time then
1385                   { status with p1 = b; p1_latch = b; }
1386                 else
1387                   status
1388             | `P3 b ->
1389               if status.clock >= time then
1390                 { status with p3 = b; p3_latch = b; }
1391               else
1392                 status
1393             | `SerialBuff (`Eight b) ->
1394               let sm0 = get_bit status.scon 7 in
1395               let sm1 = get_bit status.scon 6 in
1396               (match (sm0, sm1) with
1397                   (false, false) ->
1398                       (* Mode 0: shift register.  No delay. *)
1399                     if status.clock >= time then
1400                       { status with scon = set_bit status.scon 0 true;
1401                         io   = cont;
1402                         sbuf = b }
1403                     else
1404                       status
1405                 | (false, true) ->
1406                       (* Mode 1: 8-bit UART *)
1407                       (* Explanation: 8 bit asynchronous communication.  There's a delay (epsilon)
1408                          which needs taking care of.  If we're trying to communicate at the same time
1409                          an existing communication is occurring, we assert false (else clause of first
1410                          if). *)
1411                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1412                     if status.clock >= time then
1413                           (* Waiting for nine bits, multiprocessor communication mode requires nine bits *)
1414                       if get_bit status.scon 5 then
1415                         assert false (* really: crash! *)
1416                       else
1417                         { status with serial_epsilon_in = Some (epsilon + time);
1418                           serial_v_in       = Some (`Eight b) }
1419                     else
1420                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1421                              None. *)
1422                       let Some e = status.serial_epsilon_in in
1423                       let Some v = status.serial_v_in in
1424                       if status.clock >= e then
1425                         match v with
1426                             `Eight v' ->
1427                               { status with sbuf = v';
1428                                 serial_v_in = None;
1429                                 serial_epsilon_in = None;
1430                                 scon = set_bit status.scon 0 true;
1431                                 io = cont }
1432                           | _ -> assert false (* trying to read in 9 bits instead of 8 *)
1433                       else
1434                         status
1435                   else
1436                     assert false
1437                 | (true, false) | (true, true) ->
1438                   assert false (* only got eight bits on the line when in 9 bit mode *))
1439             | `SerialBuff (`Nine (b,b')) ->
1440               let sm0 = get_bit status.scon 7 in
1441               let sm1 = get_bit status.scon 6 in
1442               match(sm0, sm1) with
1443                   (false, false) | (false, true) -> assert false
1444                 | (true, false)  | (true, true) ->
1445                       (* Modes 2 and 3: 9-bit UART *)
1446                       (* Explanation: 9 bit asynchronous communication.  There's a delay (epsilon)
1447                          which needs taking care of.  If we're trying to communicate at the same time
1448                          an existing communication is occurring, we assert false (else claus of first
1449                          if). *)
1450                   if status.serial_epsilon_in = None && status.serial_v_in = None then
1451                     if status.clock >= time then
1452                           (* waiting for nine bits, multiprocessor communication mode requires nine bits *)
1453                       if get_bit status.scon 5 then
1454                         assert false (* really: crash! *)
1455                       else
1456                         { status with serial_epsilon_in = Some (epsilon + time);
1457                           serial_v_in       = Some (`Nine (b, b')) }
1458                     else
1459                           (* Warning about incomplete case analysis here, but safe as we've already tested for
1460                              None. *)
1461                       let Some e = status.serial_epsilon_in in
1462                       let Some v = status.serial_v_in in
1463                       if status.clock >= e then
1464                         match v with
1465                             `Nine (v, v') ->
1466                               let scon' = set_bit status.scon 0 true in
1467                               { status with sbuf = v';
1468                                 serial_v_in = None;
1469                                 serial_epsilon_in = None;
1470                                 scon = set_bit scon' 2 b;
1471                                 io = cont }
1472                           | _ -> assert false (* trying to read in 8 bits instead of 9 *)
1473                       else
1474                         status
1475                   else
1476                     assert false)
1477         in
1478         { status with io = cont })
1479    | _ -> status
1480;;
1481
1482let serial_port_output status out_cont =
1483  (* Serial port output *)
1484  (let status = { status with serial_epsilon_out = Some (status.clock + status.io_epsilon);
1485    serial_v_out = Some (`Eight status.sbuf);
1486    serial_k_out = Some (snd (out_cont (status.clock + status.io_epsilon) (`SerialBuff (`Eight status.sbuf)))) } in
1487   match status.serial_epsilon_out with
1488       Some s ->
1489         if status.clock >= s then
1490           match status.serial_k_out with
1491               None -> assert false (* correct? *)
1492             | Some k' -> { status with io   = k';
1493               scon = set_bit status.scon 1 true; }
1494         else
1495           status
1496     | _ -> assert false)
1497;;
1498
1499let external_serial_interrupt status esi =
1500  (* Interrupt enabled *)
1501  if esi then
1502    (* If we're already running, then fine (todo: check for *another* interrupt
1503       and add to a queue, or something? *)
1504    if status.t1i_running then
1505      status
1506    else
1507      (* If we should be running, but aren't... *)
1508      if false then
1509        assert false
1510      else
1511        status
1512  else
1513    status
1514;;
1515
1516let external0_interrupt status e0i =
1517  (* Interrupt enabled *)
1518  if e0i then
1519    (* If we're already running, then fine (todo: check for *another* interrupt
1520       and add to a queue, or something? *)
1521    if status.t1i_running then
1522      status
1523    else
1524      (* If we should be running, but aren't... *)
1525      if false then
1526        assert false
1527      else
1528        status
1529  else
1530    status
1531;;
1532
1533let external1_interrupt status e1i =
1534  (* Interrupt enabled *)
1535  if e1i then
1536    (* If we're already running, then fine (todo: check for *another* interrupt
1537       and add to a queue, or something? *)
1538    if status.t1i_running then
1539      status
1540    else
1541      (* If we should be running, but aren't... *)
1542      if false then
1543        assert false
1544      else
1545        status
1546  else
1547    status
1548;;
1549
1550let timer0_interrupt status t0i =
1551  (* Interrupt enabled *)
1552  if t0i then
1553    (* If we're already running, then fine (todo: check for *another* interrupt
1554       and add to a queue, or something? *)
1555    if status.t1i_running then
1556      status
1557    else
1558      (* If we should be running, but aren't... *)
1559      if false then
1560        assert false
1561      else
1562        status
1563  else
1564    status
1565;;
1566
1567let timer1_interrupt status t1i =
1568  (* Interrupt enabled *)
1569  if t1i then
1570    (* If we're already running, then fine (todo: check for *another* interrupt
1571       and add to a queue, or something? *)
1572    if status.t1i_running then
1573      status
1574    else
1575      (* If we should be running, but aren't... *)
1576      if false then
1577        assert false
1578      else
1579        status
1580  else
1581    status
1582;;
1583
1584let interrupts status =
1585  let (ea,_,_,es), (et1,ex1,et0,ex0) = bits_of_byte status.ie in
1586  let (_,_,_,ps), (pt1,px1,pt0,px0) = bits_of_byte status.ip in
1587    (* DPM: are interrupts enabled? *)
1588  if ea then
1589    match (ps,pt1,px1,pt0,px0) with
1590        _ -> assert false
1591  else
1592    status
1593;;
1594
1595let execute1 status =
1596  let instr,pc,ticks = fetch status.code_memory status.pc in
1597  let status = { status with clock = status.clock + ticks; pc = pc } in
1598  let status =
1599    (match instr with
1600        `ADD (`A,d1) ->
1601          let v,c,ac,ov =
1602            add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) false
1603          in
1604          set_flags (set_arg_8 status v `A) c (Some ac) ov
1605      | `ADDC (`A,d1) ->
1606        let v,c,ac,ov =
1607          add8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1608        in
1609        set_flags (set_arg_8 status v `A) c (Some ac) ov
1610      | `SUBB (`A,d1) ->
1611        let v,c,ac,ov =
1612          subb8_with_c (get_arg_8 status false `A) (get_arg_8 status false d1) (get_cy_flag status)
1613        in
1614        set_flags (set_arg_8 status v `A) c (Some ac) ov
1615      | `INC `DPTR ->
1616        let cry, low_order_byte = half_add status.dpl (vect_of_int 1 `Eight) in
1617        let cry, high_order_byte = full_add status.dph (vect_of_int 0 `Eight) cry in
1618        { status with dpl = low_order_byte; dph = high_order_byte }
1619      | `INC ((`A | `REG _ | `DIRECT _ | `INDIRECT _) as d) ->
1620        let b = get_arg_8 status true d in
1621        let cry, res = half_add b (vect_of_int 1 `Eight) in
1622        set_arg_8 status res d
1623      | `DEC d ->
1624        let b = get_arg_8 status true d in
1625        let res,c,ac,ov = subb8_with_c b (vect_of_int 1 `Eight) false in
1626        set_arg_8 status res d
1627      | `MUL (`A,`B) ->
1628        let acc = int_of_vect status.acc in
1629        let b = int_of_vect status.b in
1630        let prod = acc * b in
1631        let ov = prod > 255 in
1632        let l = vect_of_int (prod  mod 256) `Eight in
1633        let h = vect_of_int (prod / 256) `Eight in
1634        let status = { status with acc = l ; b = h } in
1635         (* DPM: Carry flag is always cleared. *)
1636        set_flags status false None ov
1637      | `DIV (`A,`B) ->
1638        let acc = int_of_vect status.acc in
1639        let b = int_of_vect status.b in
1640        if b = 0 then
1641        (* CSC: ACC and B undefined! We leave them as they are. *)
1642          set_flags status false None true
1643        else
1644          let q = vect_of_int (acc / b) `Eight in
1645          let r = vect_of_int (acc mod b) `Eight in
1646          let status = { status with acc = q ; b = r } in
1647          set_flags status false None false
1648      | `DA `A ->
1649        let acc_upper_nibble, acc_lower_nibble = from_byte status.acc in
1650        if int_of_vect acc_lower_nibble > 9 or get_ac_flag status = true then
1651          let acc,cy,_,_ = add8_with_c status.acc (vect_of_int 6 `Eight) false in
1652          let acc_upper_nibble, acc_lower_nibble = from_byte acc in
1653          if int_of_vect acc_upper_nibble > 9 or cy = true then
1654            let cry,acc_upper_nibble = half_add acc_upper_nibble (vect_of_int 6 `Four) in
1655            let status = { status with acc = mk_byte acc_upper_nibble acc_lower_nibble } in
1656            set_flags status cry (Some (get_ac_flag status)) (get_ov_flag status)
1657          else
1658            status
1659        else
1660          status
1661      | `ANL (`U1(`A, ag)) ->
1662        let and_val = get_arg_8 status true `A -&- get_arg_8 status true ag in
1663        set_arg_8 status and_val `A
1664      | `ANL (`U2((`DIRECT d), ag)) ->
1665        let and_val = get_arg_8 status true (`DIRECT d) -&- get_arg_8 status true ag in
1666        set_arg_8 status and_val (`DIRECT d)
1667      | `ANL (`U3 (`C, b)) ->
1668        let and_val = get_cy_flag status && get_arg_1 status true b in
1669        set_flags status and_val None (get_ov_flag status)
1670      | `ORL (`U1(`A, ag)) ->
1671        let or_val = get_arg_8 status true `A -|- get_arg_8 status true ag in
1672        set_arg_8 status or_val `A
1673      | `ORL (`U2((`DIRECT d), ag)) ->
1674        let or_val = get_arg_8 status true (`DIRECT d) -|- get_arg_8 status true ag in
1675        set_arg_8 status or_val (`DIRECT d)
1676      | `ORL (`U3 (`C, b)) ->
1677        let or_val = get_cy_flag status || get_arg_1 status true b in
1678        set_flags status or_val None (get_ov_flag status)
1679      | `XRL (`U1(`A, ag)) ->
1680        let xor_val = get_arg_8 status true `A -^- get_arg_8 status true ag in
1681        set_arg_8 status xor_val `A
1682      | `XRL (`U2((`DIRECT d), ag)) ->
1683        let xor_val = get_arg_8 status true (`DIRECT d) -^- get_arg_8 status true ag in
1684        set_arg_8 status xor_val (`DIRECT d)
1685      | `CLR `A -> set_arg_8 status (zero `Eight) `A
1686      | `CLR `C -> set_arg_1 status false `C
1687      | `CLR ((`BIT _) as a) -> set_arg_1 status false a
1688      | `CPL `A -> { status with acc = complement status.acc }
1689      | `CPL `C -> set_arg_1 status (not $ get_arg_1 status true `C) `C
1690      | `CPL ((`BIT _) as b) -> set_arg_1 status (not $ get_arg_1 status true b) b
1691      | `RL `A -> { status with acc = rotate_left status.acc }
1692      | `RLC `A ->
1693        let old_cy = get_cy_flag status in
1694        let n1, n2 = from_byte status.acc in
1695        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1696        let status = set_arg_1 status b1 `C in
1697        { status with acc = mk_byte (mk_nibble b2 b3 b4 b5) (mk_nibble b6 b7 b8 old_cy) }
1698      | `RR `A -> { status with acc = rotate_right status.acc }
1699      | `RRC `A ->
1700        let old_cy = get_cy_flag status in
1701        let n1, n2 = from_byte status.acc in
1702        let (b1,b2,b3,b4),(b5,b6,b7,b8) = from_nibble n1, from_nibble n2 in
1703        let status = set_arg_1 status b8 `C in
1704        { status with acc = mk_byte (mk_nibble old_cy b1 b2 b3) (mk_nibble b4 b5 b6 b7) }
1705      | `SWAP `A ->
1706        let (acc_nibble_upper, acc_nibble_lower) = from_byte status.acc in
1707        { status with acc = mk_byte acc_nibble_lower acc_nibble_upper }
1708      | `MOV(`U1(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1709      | `MOV(`U2(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1710      | `MOV(`U3(b1, b2)) -> set_arg_8 status (get_arg_8 status false b2) b1
1711      | `MOV(`U4(b1,b2)) -> set_arg_16 status (get_arg_16 status b2) b1
1712      | `MOV(`U5(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1713      | `MOV(`U6(b1,b2)) -> set_arg_1 status (get_arg_1 status false b2) b1
1714      | `MOVC (`A, `A_DPTR) ->
1715        let big_acc = mk_word (zero `Eight) status.acc in
1716        let dptr = mk_word status.dph status.dpl in
1717        let cry, addr = half_add dptr big_acc in
1718        let lookup = Physical.WordMap.find addr status.code_memory in
1719        { status with acc = lookup }
1720      | `MOVC (`A, `A_PC) ->
1721        let big_acc = mk_word (zero `Eight) status.acc in
1722        (* DPM: Under specified: does the carry from PC incrementation affect the *)
1723        (*      addition of the PC with the DPTR? At the moment, no.              *)
1724        let cry,inc_pc = half_add status.pc (vect_of_int 1 `Sixteen) in
1725        let status = { status with pc = inc_pc } in
1726        let cry,addr = half_add inc_pc big_acc in
1727        let lookup = Physical.WordMap.find addr status.code_memory in
1728        { status with acc = lookup }
1729      (* data transfer *)
1730      (* DPM: MOVX currently only implements the *copying* of data! *)
1731      | `MOVX (`U1 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1732      | `MOVX (`U2 (a1, a2)) -> set_arg_8 status (get_arg_8 status false a2) a1
1733      | `SETB b -> set_arg_1 status true b
1734      | `PUSH a ->
1735       (* DPM: What happens if we overflow? *)
1736        let cry,new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1737        let status = { status with sp = new_sp } in
1738        write_at_sp status (get_arg_8 status false a)
1739      | `POP (`DIRECT b) ->
1740        let contents = read_at_sp status in
1741        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1742        let status = { status with sp = new_sp } in
1743        let status = set_arg_8 status contents (`DIRECT b) in
1744        status
1745      | `XCH(`A, arg) ->
1746        let old_arg = get_arg_8 status false arg in
1747        let old_acc = status.acc in
1748        let status = set_arg_8 status old_acc arg in
1749        { status with acc = old_arg }
1750      | `XCHD(`A, i) ->
1751        let acc_upper_nibble, acc_lower_nibble = from_byte $ get_arg_8 status false `A in
1752        let ind_upper_nibble, ind_lower_nibble = from_byte $ get_arg_8 status false i in
1753        let new_acc = mk_byte acc_upper_nibble ind_lower_nibble in
1754        let new_reg = mk_byte ind_upper_nibble acc_lower_nibble in
1755        let status = { status with acc = new_acc } in
1756        set_arg_8 status new_reg i
1757      (* program branching *)
1758      | `JC (`REL rel) ->
1759        if get_cy_flag status then
1760          let cry, new_pc = half_add status.pc (sign_extension rel) in
1761          { status with pc = new_pc }
1762        else
1763          status
1764      | `JNC (`REL rel) ->
1765        if not $ get_cy_flag status then
1766          let cry, new_pc = half_add status.pc (sign_extension rel) in
1767          { status with pc = new_pc }
1768        else
1769          status
1770      | `JB (b, (`REL rel)) ->
1771        if get_arg_1 status false b then
1772          let cry, new_pc = half_add status.pc (sign_extension rel) in
1773          { status with pc = new_pc }
1774        else
1775          status
1776      | `JNB (b, (`REL rel)) ->
1777        if not $ get_arg_1 status false b then
1778          let cry, new_pc = half_add status.pc (sign_extension rel) in
1779          { status with pc = new_pc }
1780        else
1781          status
1782      | `JBC (b, (`REL rel)) ->
1783        let status = set_arg_1 status false b in
1784        if get_arg_1 status false b then
1785          let cry, new_pc = half_add status.pc (sign_extension rel) in
1786          { status with pc = new_pc }
1787        else
1788          status
1789      | `RET ->
1790        (* DPM: What happens when we underflow? *)
1791        let high_bits = read_at_sp status in
1792        let new_sp,cy,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1793        let status = { status with sp = new_sp } in
1794        let low_bits = read_at_sp status in
1795        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) cy in
1796        let status = { status with sp = new_sp } in
1797        { status with pc = mk_word high_bits low_bits }
1798      | `RETI ->
1799        let high_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        let low_bits = read_at_sp status in
1803        let new_sp,_,_,_ = subb8_with_c status.sp (vect_of_int 1 `Eight) false in
1804        let status = { status with sp = new_sp } in
1805        { status with pc = mk_word high_bits low_bits }
1806      | `ACALL (`ADDR11 a) ->
1807        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1808        let status = { status with sp = new_sp } in
1809        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1810        let status = write_at_sp status pc_lower_byte in
1811        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1812        let status = { status with sp = new_sp } in
1813        let status = write_at_sp status pc_upper_byte in
1814        let addr = addr16_of_addr11 status.pc a in
1815        { status with pc = addr }
1816      | `LCALL (`ADDR16 addr) ->
1817        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1818        let status = { status with sp = new_sp } in
1819        let pc_upper_byte, pc_lower_byte = from_word status.pc in
1820        let status = write_at_sp status pc_lower_byte in
1821        let cry, new_sp = half_add status.sp (vect_of_int 1 `Eight) in
1822        let status = { status with sp = new_sp } in
1823        let status = write_at_sp status pc_upper_byte in
1824        { status with pc = addr }
1825      | `AJMP (`ADDR11 a) ->
1826        let addr = addr16_of_addr11 status.pc a in
1827        { status with pc = addr }
1828      | `LJMP (`ADDR16 a) ->
1829        { status with pc = a }
1830      | `SJMP (`REL rel) ->
1831        let cry, new_pc = half_add status.pc (sign_extension rel) in
1832        { status with pc = new_pc }
1833      | `JMP `IND_DPTR ->
1834        let dptr = mk_word status.dph status.dpl in
1835        let big_acc = mk_word (zero `Eight) status.acc in
1836        let cry, jmp_addr = half_add big_acc dptr in
1837        let cry, new_pc = half_add status.pc jmp_addr in
1838        { status with pc = new_pc }
1839      | `JZ (`REL rel) ->
1840        if status.acc = zero `Eight then
1841          let cry, new_pc = half_add status.pc (sign_extension rel) in
1842          { status with pc = new_pc }
1843        else
1844          status
1845      | `JNZ (`REL rel) ->
1846        if status.acc <> zero `Eight then
1847          let cry, new_pc = half_add status.pc (sign_extension rel) in
1848          { status with pc = new_pc }
1849        else
1850          status
1851      | `CJNE ((`U1 (`A, ag)), `REL rel) ->
1852        let new_carry = status.acc < get_arg_8 status false ag in
1853        if get_arg_8 status false ag <> status.acc then
1854          let cry, new_pc = half_add status.pc (sign_extension rel) in
1855          let status = set_flags status new_carry None (get_ov_flag status) in
1856          { status with pc = new_pc;  }
1857        else
1858          set_flags status new_carry None (get_ov_flag status)
1859      | `CJNE ((`U2 (ag, `DATA d)), `REL rel) ->
1860        let new_carry = get_arg_8 status false ag < d in
1861        if get_arg_8 status false ag <> d then
1862          let cry, new_pc = half_add status.pc (sign_extension rel) in
1863          let status = { status with pc = new_pc } in
1864          set_flags status new_carry None (get_ov_flag status)
1865        else
1866          set_flags status new_carry None (get_ov_flag status)
1867      | `DJNZ (ag, (`REL rel)) ->
1868        let new_ag,_,_,_ = subb8_with_c (get_arg_8 status true ag) (vect_of_int 1 `Eight) false in
1869        let status = set_arg_8 status new_ag ag in
1870        if new_ag <> zero `Eight then
1871          let cry, new_pc = half_add status.pc (sign_extension rel) in
1872          { status with pc = new_pc }
1873        else
1874          status
1875      | `NOP -> status) in
1876  let status = timers status ticks in
1877  let in_cont, `Out out_cont = status.io in
1878  let status = serial_port_input status in_cont in
1879  let status = serial_port_output status out_cont in
1880  let status = interrupts status in
1881  { status with previous_p1_val = get_bit status.p3 4;
1882    previous_p3_val = get_bit status.p3 5 }
1883;;
1884
1885(*
1886OLD output routine:
1887           (* Serial port output, part one *)
1888           let status =
1889             (match status.expected_out_time with
1890               `At t when status.clock >= t ->
1891                 { status with scon = set_bit status.scon 1 true; expected_out_time = `None }
1892              | _ -> status) in
1893
1894             (if status.expected_out_time = `Now then
1895               if get_bit status.scon 7 then
1896                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Nine ((get_bit status.scon 3), status.sbuf))) in
1897                   { status with expected_out_time = `At exp_time; io = new_cont }
1898               else
1899                 let exp_time, new_cont = out_cont status.clock (`SerialBuff (`Eight status.sbuf)) in
1900                   { status with expected_out_time = `At exp_time; io = new_cont }               
1901             else
1902               status) in
1903*)
1904
1905let rec execute f s =
1906  let cont =
1907    try f s; true
1908    with Halt -> false
1909  in
1910  if cont then execute f (execute1 s)
1911  else s
1912;;
Note: See TracBrowser for help on using the repository browser.