Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ASMInterpret.ml @ 2321

Last change on this file since 2321 was 2321, checked in by campbell, 9 years ago
Add toolstick branch of the prototype.
File size: 81.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: Deliverables/D2.2/8051-toolstick/src/ASM/ASMInterpret.ml @ 2321

Download in other formats: