open Code;; open Gen;; open Frame;; type erreur = | Alignement of int | Débordement of string | Étiquette of string exception Erreur of erreur;; exception Interne of string;; exception Exit;; let erreur x = raise (Erreur x);; (* linking *) let code = Hashtbl.create 20;; let rec linearize = function | Seq l :: code -> linearize (l @ code) | instr :: code -> instr :: linearize code | [] -> [] ;; let rec load = function [] -> () | h :: t -> begin match h with Code.Label lab -> Hashtbl.add code lab t | Seq c -> load c | _ -> () end; load t ;; (* runtime *) let mem = Array.create 10000 (0);; let next_mem = ref 0;; let mem_alloc size = let address = !next_mem in next_mem := !next_mem + size; wordsize * address;; let initial_registers = Array.create 200 (0);; let reg = ref initial_registers;; let new_reg() = Array.copy !reg;; let get s t n = try t.(n) with Invalid_argument _ -> Printf.fprintf stderr "Get %s %d" s n; prerr_newline(); erreur (Débordement s);; let set s t n v = try t.(n) <- v;() with Invalid_argument _ -> Printf.fprintf stderr "Set %s %d" s n; prerr_newline(); erreur (Débordement s);; let get_temp t = get "Temp" !reg (temp_int t);; let set_temp t v = set "Temp" !reg (temp_int t) v;; let get_mem a = if a mod wordsize <> 0 then erreur (Alignement a) else get "Mem" mem (a / wordsize);; let set_mem a v= if a mod wordsize <> 0 then erreur (Alignement a) else set "Mem" mem (a/wordsize) v;; (* primitives *) let bin b x y = match b with | Minus -> x - y | Plus -> x + y | Times -> x * y | Div -> x / y | Gt -> if x > y then 1 else 0 | Ge -> if x >= y then 1 else 0 | Lt -> if x < y then 1 else 0 | Le -> if x <= y then 1 else 0 | Eq -> if x = y then 1 else 0 | Ne -> if x <> y then 1 else 0 ;; let branch b x y t f = if begin match b with | Req -> x = y | Rne -> x <> y | Rle -> x <= y | Rge -> x >= y | Rlt -> x < y | Rgt -> x > y end then t else f ;; exception Goto of label;; exception Exit;; let rec exp = function Const n -> n | Name l when l = global_space -> 0 | Name _ -> failwith "Name" | Temp t -> get_temp t | Mem e -> get_mem (exp e) | Bin (binop, e1,e2) -> let v1 = exp e1 in let v2 = exp e2 (* necessaire pour forcer l'ordre d'evaluation gauche-droite *) in bin binop v1 v2 | Call (f, []) when f = read_int -> Pervasives.read_int() | Call (f, [e1]) when f = write_int -> print_int (exp e1); 0 | Call (f, [e1]) when f = writeln_int -> print_int (exp e1); print_newline(); 0 | Call (f, [e1]) when f = alloc -> mem_alloc (exp e1) | Call (f, args) -> let args = List.map exp args in let saved_reg = !reg in reg := new_reg(); List.iter2 (fun v r -> set_temp r v) args (Frame.frame_args f); goto (Frame.frame_return f) (Frame.frame_name f); let v = match Frame.frame_result f with Some r -> get_temp r | _ -> 0 in reg := saved_reg; v and stm return = function | [] -> () | Label _ :: next -> stm return next | Move_temp (t, e) :: next -> let v = exp e in set_temp t v; stm return next | Move_mem (e1, e2) :: next -> let v1 = exp e1 in let v2 = exp e2 in set_mem v1 v2; stm return next | Exp e :: next -> let _ = exp e in stm return next | Jump l :: _ when l = return -> () (* | Jump l :: _ when l = !global_return -> raise Exit *) | Jump l :: _ -> goto return l | Cjump (cmp, e1, e2, l1, l2) :: _ -> let v1 = exp e1 in let v2 = exp e2 in (* necessaire pour forcer l'ordre d'evaluation gauche-droite *) goto return (branch cmp v1 v2 l1 l2) | Seq _ ::_ -> raise (Interne "sequence in linearized code") and goto return l = let code = try Hashtbl.find code l with Not_found -> erreur (Étiquette (label_string l)) in stm return code ;; let reset() = next_mem := 0; Hashtbl.clear code;; let program p = try reset(); let (f, c) = p.Trans.main in load (linearize c); List.iter (fun (f,c) -> load (linearize c)) p.Trans.procedures; let _ = mem_alloc p.Trans.number_of_globals in goto (Frame.frame_return f) (Frame.frame_name f); with | Erreur x -> Printf.fprintf stderr "Simulation erreur\n"; begin match x with | Alignement n -> Printf.fprintf stderr "Address is not aligned %d" n | Débordement s -> Printf.fprintf stderr "Débordement: %s" s | Étiquette s -> Printf.fprintf stderr "Undefined label: %s" s end; prerr_newline() | Env.Free s -> Printf.fprintf stderr "Erreur Simulation erreur\n"; | Failure "int_of_string" -> Printf.fprintf stderr "Erreur de saisie: chaîne non convertible en un entier"; print_newline() | Interne s -> Printf.fprintf stderr "Simulation erreur"; print_newline() | Exit -> () ;;