heptagon/minils/sequential/obc.ml
2010-06-15 10:49:03 +02:00

433 lines
12 KiB
OCaml

(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Object code internal representation *)
(* $Id$ *)
open Misc
open Names
open Ident
type var_name = ident
type type_name = longname
type fun_name = longname
type class_name = name
type instance_name = longname
type obj_name = name
type op_name = longname
type field_name = longname
type ty =
| Tint
| Tfloat
| Tid of type_name
| Tarray of ty * int
type type_dec =
{ t_name : name;
t_desc : tdesc }
and tdesc =
| Type_abs
| Type_enum of name list
| Type_struct of (name * ty) list
type const =
| Cint of int
| Cfloat of float
| Cconstr of longname
| Cconst_array of int * const
type lhs =
| Var of var_name
| Mem of var_name
| Field of lhs * field_name
| Array of lhs * exp
type exp =
| Lhs of lhs
| Const of const
| Op of op_name * exp list
| Struct of type_name * (field_name * exp) list
| Array of exp list
type act =
| Assgn of lhs * exp
| Step_ap of lhs list * obj_name * exp list
| Comp of act * act
| Case of exp * (longname * act) list
| For of var_name * int * int * act
| Reinit of obj_name
| Nothing
| Array_select_slice of lhs * exp * int * int
| Array_select_dyn of lhs * exp * exp list * int list * exp (* res, var, indices, bounds, def value*)
| Array_iterate of lhs list * iterator_name * obj_name * int * exp list
| Array_concat of lhs * exp * exp
| Field_update of lhs * exp * longname * exp (* var, record, field, value*)
type var_dec =
{ v_name : var_name;
v_type : ty;
v_pass_by_ref : bool; }
type obj_dec =
{ obj : obj_name;
cls : instance_name;
n : int; }
type step_fun =
{ inp : var_dec list;
out : var_dec list;
local : var_dec list;
controllables : var_dec list; (* GD : ugly patch to delay controllable
variables definition to target code
generation *)
bd : act }
type reset_fun = act
type class_def =
{ cl_id : class_name;
mem : var_dec list;
objs : obj_dec list;
reset : reset_fun;
step : step_fun; }
type program =
{ o_pragmas: (name * string) list;
o_opened : name list;
o_types : type_dec list;
o_defs : class_def list }
(** [is_scalar_type vd] returns whether the type corresponding
to this variable declaration is scalar (ie a type that can
be returned by a C function). *)
let is_scalar_type vd =
let pint = Modname({ qual = "Pervasives"; id = "int" }) in
let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in
let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in
match vd.v_type with
| Tint | Tfloat -> true
| Tid name_int when name_int = pint -> true
| Tid name_float when name_float = pfloat -> true
| Tid name_bool when name_bool = pbool -> true
| _ -> false
let actual_type ty =
match ty with
| Tid(Name("float"))
| Tid(Modname { qual = "Pervasives"; id = "float" }) -> Tfloat
| Tid(Name("int"))
| Tid(Modname { qual = "Pervasives"; id = "int" }) -> Tint
| _ -> ty
let rec var_name x =
match x with
| Var x -> x
| Mem x -> x
| Field(x,_) -> var_name x
(** Returns whether an object of name n belongs to
a list of var_dec. *)
let rec vd_mem n = function
| [] -> false
| vd::l -> vd.v_name = n or (vd_mem n l)
(** Returns the var_dec object corresponding to the name n
in a list of var_dec. *)
let rec vd_find n = function
| [] -> Format.printf "Not found var %s\n" (name n); raise Not_found
| vd::l ->
if vd.v_name = n then vd else vd_find n l
let lhs_of_exp = function
| Lhs l -> l
| _ -> assert false
module Printer =
struct
open Format
let rec print_list ff print sep = function
| [] -> ()
| [x] -> print ff x
| x :: l ->
print ff x;
fprintf ff "%s@ " sep;
print_list ff print sep l
(* Infix chars are surrounded by parenthesis *)
let is_infix =
let module StrSet = Set.Make(String) in
let set_infix =
List.fold_right
StrSet.add
["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
StrSet.empty in
fun s -> StrSet.mem s set_infix
let print_name ff s =
let c = String.get s 0 in
let s = if is_infix s then "(" ^ s ^ ")"
else match c with
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s
| '*' -> "( " ^ s ^ " )"
| _ -> if s = "()" then s else "(" ^ s ^ ")" in
fprintf ff "%s" s
let print_longname ff ln =
let ln = (* currentname ln*) ln in
match ln with
| Name(m) -> print_name ff m
| Modname({ qual = "Pervasives"; id = m }) -> print_name ff m
| Modname({ qual = m1; id = m2 }) ->
fprintf ff "%s." m1; print_name ff m2
let print_ident ff id =
fprintf ff "%s" (name id)
let rec print_type ff = function
| Tint -> fprintf ff "int"
| Tfloat -> fprintf ff "float"
| Tid(id) -> print_longname ff id
| Tarray(ty, n) ->
print_type ff ty;
fprintf ff "^%d" n
let print_vd ff vd =
fprintf ff "@[<v>";
print_ident ff vd.v_name;
fprintf ff ": ";
if vd.v_pass_by_ref then
fprintf ff "&";
print_type ff vd.v_type;
fprintf ff "@]"
let print_obj ff { cls = cls; obj = obj; n = n } =
fprintf ff "@[<v>"; print_name ff obj;
fprintf ff " : "; print_longname ff cls;
if n <> 1 then
fprintf ff "[%d]" n;
fprintf ff ";@]"
let rec print_c ff = function
| Cint i -> fprintf ff "%d" i
| Cfloat f -> fprintf ff "%f" f
| Cconstr(tag) -> print_longname ff tag
| Cconst_array(n,c) ->
print_c ff c;
fprintf ff "^%d" n
let rec print_lhs ff e =
match e with
| Var x -> print_ident ff x
| Mem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")"
| Field (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f)
let rec print_exps ff e_list = print_list ff print_exp "," e_list
and print_exp ff = function
| Lhs lhs -> print_lhs ff lhs
| Const c -> print_c ff c
| Op(op, e_list) -> print_op ff op e_list
| Struct(_,f_e_list) ->
fprintf ff "@[<v 1>{";
print_list ff
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
print_exp ff e)
";" f_e_list;
fprintf ff "}@]"
| Array e_list ->
fprintf ff "@[[";
print_list ff print_exp ";" e_list;
fprintf ff "]@]"
| Array_select(x, idx) ->
print_exp ff x;
fprintf ff "[";
print_list ff (fun ff -> fprintf ff "%d") "][" idx;
fprintf ff "]"
and print_op ff op e_list =
print_longname ff op;
fprintf ff "(@["; print_list ff print_exp ", " e_list;
fprintf ff ")@]"
let print_asgn ff pref x e =
fprintf ff "@[%s" pref; print_lhs ff x; fprintf ff " = ";
fprintf ff "@["; print_exp ff e; fprintf ff "@]";
fprintf ff "@]"
let rec print_act ff a =
match a with
| Assgn (x, e) -> print_asgn ff "" x e
| Comp (a1, a2) ->
fprintf ff "@[<v>";
print_act ff a1;
fprintf ff ";@,";
print_act ff a2;
fprintf ff "@]"
| Case(e, tag_act_list) ->
fprintf ff "@[<v>@[<v 2>switch (";
print_exp ff e; fprintf ff ") {@,";
print_tag_act_list ff tag_act_list;
fprintf ff "@]@,}@]"
| Step_ap (var_list, o, es) ->
fprintf ff "@[(";
print_list ff print_lhs "," var_list;
fprintf ff "@])";
fprintf ff " = "; print_name ff o; fprintf ff ".step(";
fprintf ff "@["; print_exps ff es; fprintf ff "@]";
fprintf ff ")"
| Reinit o ->
print_name ff o; fprintf ff ".reset()"
| Nothing -> fprintf ff "()"
| Array_select_slice (var, e, idx1, idx2) ->
fprintf ff "@[";
print_lhs ff var;
fprintf ff " = ";
print_exp ff e;
fprintf ff "[%d..%d]" idx1 idx2;
fprintf ff "@]"
| Array_select_dyn (var, x, idx, _, defe) ->
fprintf ff "@[";
print_lhs ff var;
fprintf ff " = ";
fprintf ff "@[";
print_exp ff x;
fprintf ff "[";
print_list ff print_exp "][" idx;
fprintf ff "] default ";
print_exp ff defe;
fprintf ff "@]"
| Array_update (x, e1, idx, e2) ->
fprintf ff "@[";
print_lhs ff x;
fprintf ff " = ";
print_exp ff e1;
fprintf ff " with [";
print_list ff (fun ff -> fprintf ff "%d") "][" idx;
fprintf ff "] = ";
print_exp ff e2;
fprintf ff "@]"
| Array_repeat (x, n, e) ->
fprintf ff "@[";
print_lhs ff x;
fprintf ff " = ";
print_exp ff e;
fprintf ff "^%d" n
| Array_iterate (o_list, it, f, n, e_list) ->
fprintf ff "@[(";
print_list ff print_lhs ", " o_list;
fprintf ff ") = ";
fprintf ff "(";
fprintf ff "%s" (iterator_to_string it);
fprintf ff " ";
print_name ff f;
fprintf ff " <<%d>>) (@[" n;
print_list ff print_exp "," e_list;
fprintf ff ")@]@]"
| Array_concat (x, e1, e2) ->
fprintf ff "@[";
print_lhs ff x;
fprintf ff " = ";
print_exp ff e1;
fprintf ff " @@ ";
print_exp ff e2
| Field_update (x, e1, f, e2) ->
fprintf ff "@[";
print_lhs ff x;
fprintf ff " = ";
print_exp ff e1;
fprintf ff " with .";
print_longname ff f;
fprintf ff " = ";
print_exp ff e2;
fprintf ff "@]"
and print_tag_act_list ff tag_act_list =
print_list ff
(fun ff (tag, a) ->
fprintf ff "@[<hov 2>case@ ";
print_longname ff tag;
fprintf ff ":@ ";
print_act ff a;
fprintf ff "@]") "" tag_act_list
let print_step ff { inp = inp; out = out; local = nl; bd = bd } =
fprintf ff "@[<v 2>";
fprintf ff "step(@[";
print_list ff print_vd ";" inp;
fprintf ff "@]) returns (@[";
print_list ff print_vd ";" out;
fprintf ff "@]){@,";
if nl <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list ff print_vd ";" nl;
fprintf ff ";@]@,"
end;
print_act ff bd;
fprintf ff "}@]"
let print_reset ff act =
fprintf ff "@[<v 2>";
fprintf ff "reset() {@,";
print_act ff act;
fprintf ff "}@]"
let print_def ff
{ cl_id = id; mem = mem; objs = objs; reset = reset; step = step } =
fprintf ff "@[<v 2>machine "; print_name ff id; fprintf ff " =@,";
if mem <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list ff print_vd ";" mem;
fprintf ff ";@]@,"
end;
if objs <> [] then begin
fprintf ff "@[<hov 4>obj ";
print_list ff print_obj ";" objs;
fprintf ff ";@]@,"
end;
print_reset ff reset;
fprintf ff "@,";
print_step ff step;
fprintf ff "@]"
let print_type_def ff { t_name = name; t_desc = tdesc } =
match tdesc with
| Type_abs -> fprintf ff "@[type %s@\n@]" name
| Type_enum(tag_name_list) ->
fprintf ff "@[type %s = " name;
print_list ff print_name "| " tag_name_list;
fprintf ff "@\n@]"
| Type_struct(f_ty_list) ->
fprintf ff "@[type %s = " name;
fprintf ff "@[<v 1>{";
print_list ff
(fun ff (field, ty) ->
print_name ff field;
fprintf ff ": ";
print_type ff ty) ";" f_ty_list;
fprintf ff "}@]@.@]"
let print_open_module ff name =
fprintf ff "@[open ";
print_name ff name;
fprintf ff "@.@]"
let print_prog ff { o_opened = modules; o_types = types; o_defs = defs } =
List.iter (print_open_module ff) modules;
List.iter (print_type_def ff) types;
List.iter (fun def -> (print_def ff def; fprintf ff "@ ")) defs
let print oc p =
let ff = formatter_of_out_channel oc in
fprintf ff "@[-- Code generated by the MiniLucid Compiler@.";
fprintf ff "@[<v>"; print_prog ff p; fprintf ff "@]@]@."
end