Changeset 100 for Deliverables

Timestamp:

Sep 21, 2010, 4:43:33 PM (10 years ago)

Author:

mulligan

Message:

More added to ASMInterpret.

Location:

Deliverables/D4.1

Files:

• ASM.mli (modified) (1 diff)
• ASMInterpret.ml (modified) (7 diffs)
• ASMInterpret.mli (modified) (1 diff)

Deliverables/D4.1/ASM.mli

@@ -97 +97 @@
 type labelled_instruction =
  [ instruction
+ | `Cost of string
  | `Label of string
- | `Cost of string ]
+ | `Jmp of string
+ | `Call of string
+ ]

Deliverables/D4.1/ASMInterpret.ml

@@ -4 +4 @@
 
 exception Fetch_exception of string
+exception CodeTooLarge
 
 type time = int;;
@@ -46 +47 @@
  }
 
-let empty = {
+let initialize = {
   code_memory = WordMap.empty;
   low_internal_ram = Byte7Map.empty;
@@ -55 +56 @@
 
   p0 = zero `Eight;
-  sp = zero `Eight;
+  sp = vect_of_int 7 `Eight;
   dpl = zero `Eight;
   dph = zero `Eight;
@@ -649 +650 @@
 ;;
 
+let fold_lefti f =
+ let rec aux i acc =
+  function
+     [] -> acc
+   | he::tl -> aux (i+1) (f i acc he) tl
+ in
+  aux 0
+;;
+
+let load_code_memory = fold_lefti (fun i mem v -> WordMap.add (vect_of_int i `Sixteen) v mem) WordMap.empty
+
+let load l status = { status with code_memory = load_code_memory l }
+
+module StringMap = Map.Make(String);;
+
+let assembly l =
+ let pc,labels =
+  List.fold_left
+   (fun ((pc,labels) as acc) i ->
+     match i with
+        `Label s -> pc, StringMap.add s pc labels
+      | `Cost _ -> acc
+      | `Jmp s 
+      | `Call s -> pc + 3, labels  (*CSC: very stupid: always expand to worst opcode *)
+      | #instruction as i ->
+        let i',pc',_ = fetch (load_code_memory (assembly1 i)) (vect_of_int 0 `Sixteen) in
+         assert (i = i');
+         (pc + int_of_vect pc',labels)
+   ) (0,StringMap.empty) l
+ in
+  if pc >= 65536 then
+   raise CodeTooLarge
+  else
+;;
+
 let get_address_of_register status (b1,b2,b3) =
  let bu,bl = from_byte status.psw in
@@ -676 +712 @@
  function
     `DIRECT addr ->
-       (match addr with
-          (false,r1,r2,r3),n1 ->
+       let n0, n1 = from_byte addr in
+       (match from_nibble n0 with
+          (false,r1,r2,r3) ->
             Byte7Map.find (mk_byte7 r1 r2 r3 n1) status.low_internal_ram
-        | (true,r1,r2,r3),n1 ->
+        | (true,r1,r2,r3) ->
              (*CSC: SFR access, TO BE IMPLEMENTED *)
             assert false)
@@ -805 +842 @@
 ;;
 
-(*
 let execute1 status =
  let instr,pc,ticks = fetch status.code_memory status.pc in
  let status = { status with clock = status.clock + ticks; pc = pc } in
   match instr with
-     ADD (`A,d1) ->
+     `ADD (`A,d1) ->
       let v,c,ac,ov =
        add8_with_c (get_arg_8 status `A) (get_arg_8 status d1) false
       in
        set_flags (set_arg8 status v `A) c (Some ac) ov
+(*
    | ADDC (`A,d1) ->
       let v,c,ac,ov =
@@ -1172 +1209 @@
  | NOP -> status
 ;;
-*)
+*) | _ -> assert false
+
+exception Hold;;
+
+let rec execute f s =
+ let s = execute1 s in
+ let cont =
+  try f s; true
+  with Hold -> false
+ in
+  if cont then execute f s
+  else s
+;;

Deliverables/D4.1/ASMInterpret.mli

@@ -1 @@
-exception Fetch_exception of string
+exception CodeTooLarge
 
-type time = int
+type status
 
-type status = {
-  code_memory : [ `Eight ] BitVectors.vect Physical.WordMap.t;
-  low_internal_ram : [ `Eight ] BitVectors.vect Physical.Byte7Map.t;
-  high_internal_ram : [ `Eight ] BitVectors.vect Physical.Byte7Map.t;
-  external_ram : [ `Eight ] BitVectors.vect Physical.WordMap.t;
-  pc : BitVectors.word;
-  p0 : BitVectors.byte;
-  sp : BitVectors.byte;
-  dpl : BitVectors.byte;
-  dph : BitVectors.byte;
-  pcon : BitVectors.byte;
-  tcon : BitVectors.byte;
-  tmod : BitVectors.byte;
-  tl0 : BitVectors.byte;
-  tl1 : BitVectors.byte;
-  th0 : BitVectors.byte;
-  th1 : BitVectors.byte;
-  p1 : BitVectors.byte;
-  scon : BitVectors.byte;
-  sbuf : BitVectors.byte;
-  p2 : BitVectors.byte;
-  ie : BitVectors.byte;
-  p3 : BitVectors.byte;
-  ip : BitVectors.byte;
-  psw : BitVectors.byte;
-  acc : BitVectors.byte;
-  b : BitVectors.byte;
-  clock : time;
-  timer0 : BitVectors.word;
-  timer1 : BitVectors.word;
-  timer2 : BitVectors.word;
-  io : time * int -> BitVectors.byte option;
-}
+val assembly: ASM.labelled_instruction list -> BitVectors.byte list
 
-val empty : status
+val initialize: status
 
-val fetch :
-  BitVectors.byte Physical.WordMap.t ->
-  Physical.WordMap.key ->
-   ASM.instruction * [ `Sixteen ] BitVectors.vect * int
-val assembly1 : ASM.instruction -> BitVectors.byte list
+val load: BitVectors.byte list -> status -> status
+
+exception Hold  (* to be raised to stop execution *)
+
+(* the callback function is used to observe the execution
+   trace; it can raise Hold to stop execution. Otherwise
+   the processor never halts. *)
+val execute: (status -> unit) -> status -> status