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

Last change on this file since 550 was 454, checked in by sacerdot, 9 years ago

CSC + Nicolas + Dominic:

1) back-porting of changes by Nicolas from the compiler
2) new file ASMCosts to compute the cost of labels
3) several changes here and there to implement 2)

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