diff --git a/compiler/obc/ml/caml.ml b/compiler/obc/ml/caml.ml new file mode 100644 index 0000000..99b7420 --- /dev/null +++ b/compiler/obc/ml/caml.ml @@ -0,0 +1,98 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + + +(** Sequential caml code. *) + +open Misc +open Names +open Idents +open Location + +type caml_code = + { c_types: (string, type_definition) Hashtbl.t; + c_defs: (string * cexp) list; + } + +and immediate = + Cbool of bool + | Cint of int + | Cfloat of float + | Cchar of char + | Cstring of string + | Cvoid + +and cexp = + Cconstant of immediate + | Cglobal of qualified_ident + | Cvar of string + | Cconstruct of qualified_ident * cexp list + | Capply of cexp * cexp list + | Cfun of pattern list * cexp + | Cletin of is_rec * (pattern * cexp) list * cexp + | Cifthenelse of cexp * cexp * cexp + | Cifthen of cexp * cexp + | Cmatch of cexp * (pattern * cexp) list + | Ctuple of cexp list + | Crecord of (qualified_ident * cexp) list + | Crecord_access of cexp * qualified_ident + | Cseq of cexp list + | Cderef of cexp + | Cref of cexp + | Cset of string * cexp + | Clabelset of string * string * cexp + | Cmagic of cexp + +and is_rec = bool + +and pattern = + Cconstantpat of immediate + | Cvarpat of string + | Cconstructpat of qualified_ident * pattern list + | Ctuplepat of pattern list + | Crecordpat of (qualified_ident * pattern) list + | Corpat of pattern * pattern + | Caliaspat of pattern * string + | Cwildpat + +let cvoidpat = Cconstantpat(Cvoid) +let cvoid = Cconstant(Cvoid) +let crefvoid = Cref(cvoid) +let cfalse = Cconstant(Cbool(false)) +let ctrue = Cconstant(Cbool(true)) +let creftrue = Cref(ctrue) +let cdummy = Cmagic (Cconstant (Cvoid)) +let cand_op = {qual = pervasives_module;id = "&&"} +let cor_op = {qual = pervasives_module;id = "or"} +let cnot_op = {qual = pervasives_module;id = "not"} +let cand c1 c2 = Capply (Cglobal (cand_op), [c1;c2]) +let cor c1 c2 = Capply (Cglobal (cor_op), [c1;c2]) +let cnot c = Capply(Cglobal (cnot_op),[c]) +let cvoidfun e = Cfun([cvoidpat], e) +let cvoidapply e = Capply(e, [cvoid]) +let cfun params e = + match params, e with + | params, Cfun(others, e) -> Cfun(params @ others, e) + | [], _ -> cvoidfun e + | _ -> Cfun(params, e) +let capply e l = match l with [] -> cvoidapply e | _ -> Capply(e, l) +let cifthen c e = match c with Cconstant(Cbool(true)) -> e | _ -> Cifthen(c, e) +let cifthenelse c e1 e2 = + match c with + | Cconstant(Cbool(true)) -> e1 + | Cconstant(Cbool(false)) -> e2 + | _ -> Cifthenelse(c, e1, e2) +let cseq e1 e2 = + match e1, e2 with + | Cconstant(Cvoid), _ -> e2 + | _, Cconstant(Cvoid) -> e1 + | e1, Cseq l2 -> Cseq(e1 :: l2) + | Cseq(l1), e2 -> Cseq (l1 @ [e2]) + | _ -> Cseq[e1;e2] + diff --git a/compiler/obc/ml/caml_aux.ml b/compiler/obc/ml/caml_aux.ml new file mode 100644 index 0000000..48da556 --- /dev/null +++ b/compiler/obc/ml/caml_aux.ml @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: caml_aux.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) + +(* file caml-aux.ml *) +(* auxiliary functions for caml expressions *) +(* free variables *) + +open Misc;; +open Caml;; +open Declarative;; + +(* convertions from declarative structures to caml ones *) +(* immediates *) +let caml_of_declarative_immediate = function + | Dbool b -> if b then Ftrue else Ffalse + | Dint i -> Fint i + | Dfloat f -> Ffloat f + | Dchar c -> Fchar c + | Dstring s -> Fstring s + +(* globals *) +let string_of_global g = + let pref = g.dqualid.dqual in + (if (pref <> "") && (pref <> "Lucy_pervasives") then + g.dqualid.dqual^"." + else "") ^ g.dqualid.did + +(* pat_desc *) +let rec caml_pattern_of_pat_desc = function + | Dvarpat i -> Fvarpat ("x__"^(string_of_int i)) + | Dconstantpat i -> Fimpat (caml_of_declarative_immediate i) + | Dtuplepat pl -> Ftuplepat (List.map caml_of_declarative_pattern pl) + | Dconstruct0pat g -> Fconstruct0pat (string_of_global g) + | Dconstruct1pat (g,p) -> Fconstruct1pat (string_of_global g, + caml_of_declarative_pattern p) + | Drecordpat gpl -> Frecordpat (List.map + (fun (x,y) -> + (string_of_global x, + caml_of_declarative_pattern y)) + gpl) +(* patterns *) +and caml_of_declarative_pattern p = caml_pattern_of_pat_desc p.dp_desc +(* ---- end of convertions *) + +let rec flat_exp_of_pattern = function + | Fpunit -> Fim Funit + | Fimpat i -> Fim i + | Fvarpat v -> Fvar { cvar_name=v; cvar_imported=false } + | Fconstruct0pat c -> Fconstruct0 c + | Fconstruct1pat (c,p) -> Fconstruct1 (c, flat_exp_of_pattern p) + | Ftuplepat pl -> Ftuple (List.map flat_exp_of_pattern pl) + | Frecordpat cpl -> + Frecord (List.map (fun (x,y) -> (x,flat_exp_of_pattern y)) cpl) + +(* small functions manipulating lists *) +let union x1 x2 = + let rec rec_union l = function + [] -> l + | h::t -> if List.mem h l then (rec_union l t) else (rec_union (h::l) t) + in + rec_union x1 x2 + +let subtract x1 x2 = + let rec sub l = function + [] -> l + | h::t -> if List.mem h x2 then (sub l t) else (sub (h::l) t) + in + sub [] x1 + +let flat l = + let rec f ac = function + [] -> ac + | t::q -> f (ac@t) q + in + f [] l + +let intersect x1 x2 = + let rec inter l = function + [] -> l + | h::t -> if List.mem h x1 then (inter (h::l) t) else (inter l t) + in + inter [] x2 + +(* make a variable *) +let make_var n = Fvar {cvar_name = n;cvar_imported = false} +and make_imported_var n b = Fvar {cvar_name = n;cvar_imported = b} + +let nil_ident = "Lucy__nil" +let state_ident = "Lucy__state" + +(* makes a conditional *) +let ifthenelse(c,e1,e2) = + match c with + Fim(Ftrue) -> e1 + | Fim(Ffalse) -> e2 + | _ -> Fifthenelse(c,e1,e2) + +(* makes a list of conditionnals *) +let ifseq l = + let rec ifs l = + let (c,e)::t = l in + if t = [] then + e + else + ifthenelse (c, e, ifs t) + in + ifs l + + + + + + + + + + + + + + + + diff --git a/compiler/obc/ml/caml_printer.ml b/compiler/obc/ml/caml_printer.ml new file mode 100644 index 0000000..536a407 --- /dev/null +++ b/compiler/obc/ml/caml_printer.ml @@ -0,0 +1,404 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: caml_printer.ml,v 1.20 2008-06-17 13:21:12 pouzet Exp $ *) + +(** Printing [Caml] code *) + +open Misc +open Names +open Format +open Declarative +open Declarative_printer +open Caml + +(** Generic printing of a list. + This function seems to appear in several places... *) +let print_list print print_sep l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + open_box 0; + print x; + print_sep (); + print_space (); + printrec l; + close_box () in + printrec l + +(** Prints an immediate. A patch is needed on float number for + [ocaml] < 3.05. *) +let print_immediate i = + match i with + Cbool(b) -> print_string (if b then "true" else "false") + | Cint(i) -> print_int i + | Cfloat(f) -> print_float f + | Cchar(c) -> print_char '\''; print_char c; print_char '\'' + | Cstring(s) -> print_string "\""; + print_string (String.escaped s); + print_string "\"" + | Cvoid -> print_string "()" + +(** Prints a name. 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 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 + print_string s + +(** Prints a global name *) +let print_qualified_ident {qual=q;id=n} = + (* special case for values imported from the standard library *) + if (q = pervasives_module) or (q = Modules.compiled_module_name ()) + or (q = "") + then print_name n + else + begin + print_string q; + print_string "."; + print_name n + end + +let priority exp = + match exp with + Crecord _ | Crecord_access _ | Cvar _ | Ctuple _ + | Cglobal _ | Cconstant _ | Cconstruct(_, []) | Cderef _ -> 3 + | Clet _ | Cfun _ | Cseq _ -> 1 + | Cset _ | Clabelset _ + | Cref _ | Capply _ | Cmagic _ | Cconstruct _ -> 2 + | Cifthen _ | Cifthenelse _ | Cmatch _ -> 0 + +let priority_pattern p = + match p with + Cconstructpat _ | Cconstantpat _ | Cvarpat _ + | Ctuplepat _ | Crecordpat _ -> 2 + | _ -> 1 + +(** Emission of code *) +let rec print pri e = + open_box 2; + (* if the priority of the context is higher than the *) + (* priority of e, we ass a parenthesis *) + let pri_e = priority e in + if pri > pri_e then print_string "("; + begin match e with + Cconstant(e) -> print_immediate e + | Cglobal(gl) -> print_qualified_ident gl + | Cvar(s) -> print_name s + | Cconstruct(gl, e_list) -> + print_qualified_ident gl; + if e_list <> [] then print_tuple e_list + | Capply(f,l) -> + print pri_e f; + print_space (); + print_list (print (pri_e + 1)) (fun () -> ()) l + | Cfun(pat_list,e) -> + print_string "fun"; + print_space (); + print_list (print_pattern 0) (fun () -> ()) pat_list; + print_space (); + print_string "->"; + print_space (); + print 0 e + (* local definition *) + | Clet(is_rec, l, e) -> print_let is_rec l e + | Cifthenelse(e1,e2,e3) -> + print_string "if"; + print_space (); + print (pri_e - 1) e1; + print_space (); + print_string "then"; + print_space (); + print 2 e2; + print_space (); + print_string "else"; + print_space (); + print 2 e3 + | Cifthen(e1,e2) -> + print_string "if"; + print_space (); + print (pri_e - 1) e1; + print_space (); + print_string "then"; + print_space (); + print 2 e2 + | Ctuple(l) -> print_tuple l + | Crecord(l) -> + print_string "{"; + print_list + (fun (gl, e) -> print_qualified_ident gl; + print_string " = "; + print 1 e) + (fun () -> print_string ";") l; + print_string "}" + | Crecord_access(e, gl) -> + print pri_e e; + print_string "."; + print_qualified_ident gl + | Cmatch(e,l) -> + print_string "match "; + print 0 e; + print_string " with"; + print_space (); + List.iter + (fun pat_expr -> + print_string "| "; + print_match_pat_expr 2 pat_expr) l + | Cseq l -> print_list (print 2) (fun () -> print_string ";") l + | Cderef(e) -> + print_string "!"; + print pri_e e + | Cref(e) -> + print_string "ref"; + print_space (); + print (pri_e + 1) e + | Cset(s, e) -> + print_string s; + print_string " :="; + print_space (); + print pri_e e + | Clabelset(s, l, e) -> + print_string s; + print_string "."; + print_string l; + print_space (); + print_string "<-"; + print_space (); + print pri_e e + | Cmagic(e) -> + print_string "Obj.magic"; + print_space (); + print (pri_e+1) e + end; + if pri > pri_e then print_string ")"; + close_box() + +and print_tuple e_list = + print_string "("; + print_list (print 2) (fun () -> print_string ",") e_list; + print_string ")" + +and print_let_pat_expr (pat, expr) = + match pat, expr with + pat, Cfun(pat_list, expr) -> + open_box 2; + print_list (print_pattern 0) (fun () -> ()) (pat :: pat_list); + print_string " ="; + print_space (); + print 0 expr; + close_box () + | _ -> + print_pattern 0 pat; + print_string " = "; + print 0 expr + +and print_let is_rec l e = + open_box 0; + if is_rec then print_string "let rec " else print_string "let "; + print_list print_let_pat_expr + (fun () -> print_string "\n"; print_string "and ") l; + print_string " in"; + print_break 1 0; + print 0 e; + close_box () + +and print_pattern pri pat = + open_box 2; + let pri_e = priority_pattern pat in + if pri > pri_e then print_string "("; + begin match pat with + Cconstantpat(i) -> print_immediate i + | Cvarpat(v) -> print_string v + | Cconstructpat(gl, pat_list) -> + print_qualified_ident gl; + if pat_list <> [] then print_tuple_pat pat_list + | Ctuplepat(pat_list) -> + print_tuple_pat pat_list + | Crecordpat(l) -> + print_string "{"; + print_list (fun (gl, pat) -> print_qualified_ident gl; + print_string "="; + print_pattern (pri_e - 1) pat) + (fun () -> print_string ";") l; + print_string "}" + | Corpat(pat1, pat2) -> + print_pattern pri_e pat1; + print_string "|"; + print_pattern pri_e pat2 + | Caliaspat(pat, s) -> + print_pattern pri_e pat; + print_space (); + print_string "as"; + print_space (); + print_string s + | Cwildpat -> print_string "_" + end; + if pri > pri_e then print_string ")"; + close_box () + +and print_tuple_pat pat_list = + print_string "("; + print_list (print_pattern 0) (fun () -> print_string ",") pat_list; + print_string ")" + +and print_match_pat_expr prio (pat, expr) = + open_box 2; + print_pattern 0 pat; + print_space (); print_string "->"; print_space (); + print prio expr; + close_box (); + print_space ();; + +(* print a definition *) +let print_definition (name, e) = + print_string "let "; + print_let_pat_expr (Cvarpat(name), e) + +(* print code *) +let print_code e = print 0 e + +(* print types *) +let rec print_type typ = + open_box 1; + begin match typ with + Darrow(is_node, typ1, typ2) -> + print_type typ1; + if is_node then print_string " => " else print_string " -> "; + print_type typ2 + | Dproduct(ty_list) -> + print_list print_type (fun _ -> print_string " *") ty_list + | Dconstr(qual_ident, ty_list) -> + if ty_list <> [] then + begin + print_string "("; + print_list print_type (fun _ -> print_string ",") ty_list; + print_string ")"; + print_space () + end; + print_qualified_ident qual_ident + | Dtypvar(i) -> print_type_name i + | Dbase(b) -> print_base_type b + | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" + end; + close_box () + +and print_type_name n = + print_string "'a"; + print_int n + +and print_base_type b = + match b with + Dtyp_bool -> print_string "bool" + | Dtyp_int -> print_string "int" + | Dtyp_float -> print_string "float" + | Dtyp_unit -> print_string "unit" + | Dtyp_string -> print_string "string" + | Dtyp_char -> print_string "char" + +(* print variant *) +let print_variant (qualid, { arg = typ_list; res = typ }) = + print_string " | "; + print_qualified_ident qualid; + match typ_list with + [] -> (* arity = 0 *) + () + | _ -> print_string " of "; + print_list print_type (fun () -> print_string "*") typ_list + +let print_record (qualid, is_mutable, { res = typ1 }) = + if is_mutable then print_string "mutable "; + print_qualified_ident qualid; + print_string ":"; + print_type typ1; + print_string ";" + +let print_type_declaration s { d_type_desc = td; d_type_arity = l } = + open_box 2; + if l <> [] then + begin + print_string "("; + print_list print_type_name (fun _ -> print_string ",") l; + print_string ")"; + print_space () + end; + print_string s; + print_string " = "; + begin match td with + Dabstract_type -> () + | Dabbrev(ty) -> + print_type ty + | Dvariant_type variant_list -> + List.iter print_variant variant_list + | Drecord_type record_list -> + print_string "{"; + print_list print_record (fun _ -> ()) record_list; + print_string "}" + end; + print_newline (); + close_box () + +let print_type_declarations l = + let rec printrec l = + match l with + [] -> () + | [s, d] -> print_type_declaration s d + | (s, d) :: l -> + print_type_declaration s d; + print_string "and "; + printrec l in + open_box 0; + print_string "type "; + printrec l; + print_newline (); + close_box ();; + +(* the main function *) +set_max_boxes max_int ;; + +let output_expr oc e = + (* emit on channel oc *) + set_formatter_out_channel oc; + print 0 e; + print_flush () + +let output_code oc c = + (* emit on channel oc *) + set_formatter_out_channel oc; + print_code c + +let output_definitions oc d_list = + (* emit on channel oc *) + set_formatter_out_channel oc; + print_list print_definition print_newline d_list; + print_flush () + +let output oc caml_code = + set_formatter_out_channel oc; + (* print type declarations *) + let l = Misc.listoftable caml_code.c_types in + if l <> [] then print_type_declarations l; + (* print value definitions *) + print_list print_definition print_newline caml_code.c_code; + print_flush () + diff --git a/compiler/obc/ml/cenvironment.ml b/compiler/obc/ml/cenvironment.ml new file mode 100644 index 0000000..d410adb --- /dev/null +++ b/compiler/obc/ml/cenvironment.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: cenvironment.ml,v 1.1 2006-03-18 08:04:25 pouzet Exp $ *) + +open Misc +open Declarative + +(** Environment with static link **) +type cblock = + { c_block: block; (* table of free names *) + c_state: name; (* the name of the internal state *) + c_write: name; (* temporary values *) + } +type env = cblock list +let empty_env = [] +let current env = List.hd env +let cblock env = (current env).c_block +let statename env = (current env).c_state + +let push_block block env = + { c_block = block; + c_state = symbol#name; + c_write = symbol#name } :: env +let push block env = + if env = empty_env + then push_block block env + else let cblock = current env in + { cblock with c_block = block } :: env +let rec findall env i = + match env with + [] -> raise Not_found + | { c_block = b; c_state = st; c_write = wt } :: env -> + try + Hashtbl.find b.b_env i, st, wt + with + Not_found -> findall env i +let find env i = + let id, _, _ = findall env i in + id diff --git a/compiler/obc/ml/coiteration.ml b/compiler/obc/ml/coiteration.ml new file mode 100644 index 0000000..712d1cb --- /dev/null +++ b/compiler/obc/ml/coiteration.ml @@ -0,0 +1,848 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: coiteration.ml,v 1.27 2008-06-10 06:54:36 delaval Exp $ *) + + +(** Translating [declarative] code into sequential [caml] code. *) + +open Misc +open Names +open Declarative +open Rw +open Dmisc +open Caml +open Cenvironment + +let prefix_for_names = "_" +let prefix_for_inits = "_init" +let prefix_for_memos = "_pre" +let prefix_for_statics = "_static" +let prefix_for_clocks = "_cl" +let prefix_for_lasts = "__last" + +let prefix_state_type = "_state_" +let prefix_state_constr = "`St_" +let prefix_state_label = "_mem_" +let prefix_state_constr_nil = "`Snil_" +let prefix_for_self_state = "_self_" +let prefix_for_temp = "_temp_" + +(** the type of unknown states *) +(* type 'a state = Snil | St of 'a *) +let state_nil = Cconstruct(qualid prefix_state_constr_nil, []) +let state_nil_pat = Cconstructpat(qualid prefix_state_constr_nil, []) +let state_pat pat_list = Cconstructpat(qualid prefix_state_constr, pat_list) +let state e_list = Cconstruct(qualid prefix_state_constr, e_list) +let state_record name_e_list = + Crecord(List.map (fun (name, e) -> (qualid name), e) name_e_list) + +let intro_state_type () = + let tname = prefix_state_type in + let result_type = + Dconstr(qualid prefix_state_type, [Dtypvar(0)]) in + let variants = + [(qualid prefix_state_constr_nil, { arg = []; res = result_type }); + (qualid prefix_state_constr, {arg = [Dtypvar(0)]; res = result_type})] + in + let type_def = + { d_type_desc = Dvariant_type(variants); + d_type_arity = [0] } in + add_type (tname, type_def) + +(** introduce a new type for enumerated states *) +(* type ('a1,...,'an) state_k = St1 of 'a1 | ... Stm of 'an *) +let intro_enum_type n = + let l = Misc.from n in + (* name of the result type *) + let tname = prefix_state_type ^ (string_of_int(symbol#name)) in + let result_type = + Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in + let variants = + List.map + (fun name -> + (qualid (tname ^ prefix_state_constr ^ (string_of_int name)), + { arg = [Dtypvar(name)]; res = result_type })) l in + let type_def = + { d_type_desc = Dvariant_type(variants); + d_type_arity = l } in + add_type (tname, type_def); + tname ^ prefix_state_constr + +(** introduce a new type for record states *) +(* type ('a1,...,'an) state_k = {mutable name1:a1;...;mutable namen:an} *) +let intro_record_type name_value_list = + let l = Misc.from (List.length name_value_list) in + let tname = prefix_state_type ^ (string_of_int(symbol#name)) in + let result_type = + Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in + let labels = + List.map2 + (fun (name,_) ai -> + (qualid name, + true, + { res = Dtypvar(ai); arg = result_type })) name_value_list l in + let type_def = + { d_type_desc = Drecord_type(labels); + d_type_arity = l } in + add_type (tname, type_def) + +(** the intermediate code generated during the compilation process *) +type tcode = + Tlet of pattern * cexp + | Tset of string * cexp + | Tlabelset of string * string * cexp + | Tletrec of (pattern * cexp) list + | Texp of cexp + +(* and its translation into caml code *) +let rec clet tcode ce = + let code2c tcode ce = + match tcode with + Tlet(p, c) -> Clet(false, [p,c], ce) + | Tset(s, e) -> cseq (Cset(s,e)) ce + | Tlabelset(s, n, e) -> cseq (Clabelset(s, n, e)) ce + | Tletrec(l) -> Clet(true, l, ce) + | Texp(c) when ce = cvoid -> c + | Texp(c) -> cseq c ce in + match tcode with + [] -> ce + | tc :: tcode -> code2c tc (clet tcode ce) + +let cseq tcode = clet tcode cvoid +let ifthen c ce = + match c with + Cconstant(Cbool(true)) -> ce + | _ -> Cifthen(c, ce) + +let merge code ce l = + (* we make special treatments for conditionals *) + match l with + [] -> code + | [Cconstantpat(Cbool(b1)), c1; + Cconstantpat(Cbool(b2)), c2] -> + if b1 then + Texp(Cifthenelse(ce, c1, c2)) :: code + else + Texp(Cifthenelse(ce, c2, c1)) :: code + (* general case *) + | _ -> Texp(Cmatch(ce, l)) :: code + + +(** extract the set of static computations from an expression *) +let rec static acc e = + let acc, desc = match e.d_desc with + | Dconstant _ | Dvar _ | Dfun _ -> acc, e.d_desc + | Dtuple l -> + let acc, l = static_list acc l in + acc, Dtuple(l) + | Dprim(g, e_list) -> + (* pointwise application *) + let acc, e_list = static_list acc e_list in + acc, Dprim(g, e_list) + | Dconstruct(g, e_list) -> + let acc, e_list = static_list acc e_list in + acc, Dconstruct(g, e_list) + | Drecord(gl_expr_list) -> + let static_record (gl, expr) (acc, gl_expr_list) = + let acc, e = static acc expr in + acc, (gl, e) :: gl_expr_list in + let acc, l = + List.fold_right static_record gl_expr_list (acc, []) in + acc, Drecord(l) + | Drecord_access(expr, gl) -> + let acc, e = static acc expr in + acc, Drecord_access(e, gl) + | Difthenelse(e0, e1, e2) -> + let acc, e0 = static acc e0 in + let acc, e1 = static acc e1 in + let acc, e2 = static acc e2 in + acc, Difthenelse(e0, e1, e2) + | Dlet(block, e_let) -> + let acc, block = static_block acc block in + let acc, e = static acc e_let in + acc, Dlet(block, e_let) + | Dapply(is_state, f, l) -> + let acc, f = static acc f in + let acc, l = static_list acc l in + acc, Dapply(is_state, f, l) + | Deseq(e1, e2) -> + let acc, e1 = static acc e1 in + let acc, e2 = static acc e2 in + acc, Deseq(e1, e2) + | Dwhen(e1) -> + let acc, e1 = static acc e1 in + acc, Dwhen(e1) + | Dclock(ck) -> + acc, Dclock(ck) + | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> + (* this case should not arrive *) + fatal_error "static" in + acc, { e with d_desc = desc } + +and static_list acc l = + match l with + [] -> acc, [] + | e :: l -> + let acc, e = static acc e in + let acc, l = static_list acc l in + acc, e :: l + +and static_block acc b = + let acc, eq = static_eq acc b.b_equations in + acc, { b with b_equations = eq } + +(* extract the set of static computations from an equation *) +and static_eqs acc eq_list = + match eq_list with + [] -> acc, [] + | eq :: eq_list -> + let acc, eq = static_eq acc eq in + let acc, eq_list = static_eqs acc eq_list in + acc, dcons eq eq_list + +and static_eq acc eq = + match eq with + Dget _ -> acc, eq + | Dequation(pat, e) -> + let acc, e = static acc e in + acc, Dequation(pat, e) + | Dwheneq(eq, ck) -> + let acc, eq = static_eq acc eq in + acc, Dwheneq(eq, ck) + | Dmerge(is_static, e, p_block_list) -> + let acc, e = static acc e in + let acc, p_block_list = static_pat_block_list acc p_block_list in + acc, Dmerge(is_static, e, p_block_list) + | Dnext(n, e) -> + let acc, e = static acc e in + acc, Dnext(n, e) + | Dseq(eq_list) -> + let acc, eq_list = static_eqs acc eq_list in + acc, Dseq(eq_list) + | Dpar(eq_list) -> + let acc, eq_list = static_eqs acc eq_list in + acc, Dpar(eq_list) + | Dblock(block) -> + let acc, block = static_block acc block in + acc, Dblock(block) + | Dstatic(pat, e) -> + (pat, e) :: acc, no_equation + | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> + (* these cases should not arrive since control structures have *) + (* been translated into the basic kernel *) + fatal_error "static_eq" + +and static_pat_block_list acc p_block_list = + (* treat one handler *) + let static_pat_block acc (pat, block) = + let acc, block = static_block acc block in + acc, (pat, block) in + match p_block_list with + [] -> acc, [] + | pat_block :: pat_block_list -> + let acc, pat_block = static_pat_block acc pat_block in + let acc, pat_block_list = static_pat_block_list acc pat_block_list in + acc, pat_block :: pat_block_list + +(** Auxiliary definitions **) +let string_of_ident ident = + let prefix = + match ident.id_kind with + Kinit -> prefix_for_inits + | Kstatic -> prefix_for_statics + | Kmemo -> prefix_for_memos + | Kclock -> prefix_for_clocks + | Klast -> prefix_for_lasts + | _ -> prefix_for_names in + let suffix = + match ident.id_original with + None -> "" + | Some(n) when (is_an_infix_or_prefix_operator n) -> "__infix" + | Some(n) -> "__" ^ n in + prefix ^ (string_of_int ident.id_name) ^ suffix + +let string_of_name env i = + (* find the original name when it exists *) + let ident = find env i in + string_of_ident ident + +let name i = prefix_for_names ^ (string_of_int i) +let memo i = prefix_for_memos ^ (string_of_int i) +let initial i = prefix_for_inits ^ (string_of_int i) +let clock i = prefix_for_clocks ^ (string_of_int i) +let stat i = prefix_for_statics ^ (string_of_int i) + +(* the name of the current state *) +let selfstate env = prefix_for_self_state ^ (string_of_int (statename env)) + +(* access to a write variable *) +let access_write wt s = Cderef (Cvar s) + +(* makes an access to a name *) +let access env i = + let ident, st, wt = findall env i in + let s = string_of_ident ident in + match ident.id_kind with + Kinit | Kmemo | Kstatic -> + Crecord_access(Cvar(prefix_for_self_state ^ (string_of_int st)), + qualid s) + | _ -> + if is_a_write ident + then access_write wt s + else Cvar(s) + +let set name c = Tset(name, c) +let next self name c = Tlabelset(self, name, c) + +(** Compilation of functions *) +(* x1...xn. is translated into + + (1) combinatorial function + + \x1...xn.code;res + + (2) \x1...xn.self. + let self = match !self with + Nil -> let v = { ... init ... } in + self := St(v);v + | St(self) -> self in + code; + res + + r = f [...] x1...xn is translated into: + + (1) combinatorial function + + f = f [...] x1...xn + + (2) state function + + st = ref Nil initialisation part + + r = f x1...xn st step part + +Rmk: we can also write: "if reset then self := { ... }" +*) + +let co_apply env is_state (init_write, init_mem) f subst e_list = + if is_state then + (* state function *) + let st = prefix_for_names ^ (string_of_int symbol#name) in + let prefix = selfstate env in + (init_write, (st, Cref(state_nil)) :: init_mem), + Capply(f, + (subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)])) + else + (init_write, init_mem), Capply(f, subst @ e_list) + +(* prepare the initialization of memory variables *) +let cmatchstate self states = + let v = prefix_for_names ^ (string_of_int (symbol#name)) in + let st = prefix_state_constr ^ (string_of_int (symbol#name)) in + Cmatch(Cderef(Cvar(self)), + [Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self); + Cwildpat, Clet(false, [Cvarpat(v), states], + Cseq[Cset(self, + Cconstruct(qualid st, [Cvar(v)])); + Cvar(v)])]) + +(* prepare the initialization of write variables *) +let define_init_writes env init_write code = + List.fold_right + (fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code)) + init_write code + +let co_fun env + is_state params p_list static (init_write, init_mem) code result = + if init_mem <> [] then intro_record_type init_mem; + + let code = clet code result in + let code = + if init_write <> [] + then define_init_writes env init_write code + else code in + let self = selfstate env in + if is_state + then + if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code) + else Cfun(params @ p_list @ [Cvarpat(self)], + Clet(false, [Cvarpat(self), + cmatchstate self + (clet static (state_record init_mem))], + code)) + else Cfun(params @ p_list, code) + +(** Compilation of pattern matching *) +(* + match e with + P1 -> e1 + | ... + | Pn -> en + +(1) e is a static computation + +- initialisation code + let memory = match e with + P1 -> St1 { ... } + | ... + | Pn -> Stn { ... } + +- step code + match memory with + St1{...} -> step1 +| ... +| Stn{...} -> stepn + +(2) e may evolve at every instant + +- init code + ...i1... + ...in... + +- match e with + P1 -> step1 + | ... + | Pn -> stepn + +for the moment, we treat case (1) as case (2) *) + +(* +let co_static_merge e (pat, init_code_fvars_list) = + (* introduces the type definitions for the representation of states *) + let n = List.length init_code_fvars_list in + let prefix_constructor = intro_enum_type n in + + (* builds a constructor value *) + let constructor prefix number f_vars = + Cconstruct(qualid (prefix ^ (string_of_int number)), + List.map (fun name -> Cvar(name)) fvars) in + let constructor_pat prefix number f_vars = + Cconstructpat(qualid (prefix ^ (string_of_int number)), + List.map (fun name -> Cvarpat(name)) fvars) in + + (* computes the initialisation part *) + let rec states number init_code_fvars_list = + match init_code_fvars_list with + [] -> [] + | (pat, init, _, fvars) :: init_code_fvars_list -> + let pat_code = (pat, clet init (constructor prefix number fvars)) in + let pat_code_list = states (number + 1) init_code_fvars_list in + pat_code :: code_list in + + (* computes the transition part *) + let rec steps number init_code_fvars_list = + match init_code_fvars_list with + [] -> [] + | (_, _, code, fvars) :: init_code_fvars_list -> + let pat_code = (constructor_pat prefix number fvars, code) in + let pat_code_list = steps (number + 1) init_code_fvars_list in + pat_code :: pat_code_list in + + (* make the final code *) + let memory = symbol#name in + let init_code = Cmatch(e, states 0 init_code_fvars_list) in + let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in + Tlet(memory, init_code), step_code + +*) + +(** Compilation of clocks *) +let rec translate_clock env init ck = + match ck with + Dfalse -> init, cfalse + | Dtrue -> init, ctrue + | Dclockvar(n) -> init, access env n + | Don(is_on, ck, car) -> + let init, ck = translate_clock env init ck in + let init, car = translate_carrier env init car in + init, if is_on then cand car ck + else cand (cnot car) ck + +and translate_carrier env init car = + match car with + Dcfalse -> init, cfalse + | Dctrue -> init, ctrue + | Dcvar(n) -> init, access env n + | Dcglobal(g, res, ck) -> + (* a global clock allocates memory *) + (* and is compiled as a function call *) + let res = match res with None -> cfalse | Some(n) -> access env n in + let init, c = translate_clock env init ck in + let init, new_ce = + co_apply env true init (Cglobal g) [c] [res] in + init, new_ce + +(** Compiling immediate. *) +let translate_immediate i = + match i with + | Dbool(b) -> Cbool(b) + | Dint(i) -> Cint(i) + | Dfloat(f) -> Cfloat(f) + | Dchar(c) -> Cchar(c) + | Dstring(s) -> Cstring(s) + | Dvoid -> Cvoid + +(** Compiling variables. *) +let translate_var env v = + match v with + Dglobal(g) -> Cglobal(g) + | Dlocal(n) -> access env n + +(** Compiling a pattern. *) +let rec translate_pat env pat = + match pat with + | Dconstantpat(i) -> Cconstantpat(translate_immediate(i)) + | Dvarpat(s) -> Cvarpat(string_of_name env s) + | Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l) + | Dconstructpat(gl, pat_list) -> + Cconstructpat(gl, List.map (translate_pat env) pat_list) + | Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1, + translate_pat env pat2) + | Drecordpat(gl_pat_list) -> + Crecordpat + (List.map (fun (gl, pat) -> (gl, translate_pat env pat)) + gl_pat_list) + | Daliaspat(pat, i) -> Caliaspat(translate_pat env pat, + string_of_name env i) + | Dwildpat -> Cwildpat + +(* +(* add accesses to write variables defined in patterns *) +let rec add_write_access env code pat = + match pat with + Dconstantpat(i) -> code + | Dvarpat(s) when is_a_write (find env s) -> + Tset(string_of_name env s, access env s) :: code + | Dvarpat _ -> code + | Dtuplepat(l) | Dconstructpat(_, l) -> + List.fold_left (add_write_access env) code l + | Dorpat(pat1, pat2) -> + add_write_access env (add_write_access env code pat1) pat2 + | Drecordpat(gl_pat_list) -> + List.fold_left (fun code (_, pat) -> add_write_access env code pat) + code gl_pat_list + | Daliaspat(pat, i) -> + add_write_access env (add_write_access env code pat) (Dvarpat(i)) + | Dwildpat -> code +*) + +(** Compiling an expression *) +(* takes an environment giving information about variables *) +(* and an expression and returns the new code *) +let rec translate env init e = + match e.d_desc with + | Dconstant(i) -> + let i = translate_immediate i in + init, Cconstant(i) + | Dvar(v, subst) -> + let v = translate_var env v in + let init, s = translate_subst env init subst in + let v = match s with [] -> v | l -> Capply(v, l) in + init, v + | Dtuple l -> + let init, lc = translate_list env init l in + init, Ctuple(lc) + | Dfun(is_state, params, p_list, body, result) -> + (* state function *) + let env = push_block body env in + (* compiles types and clock abstractions *) + let params = translate_forall env params in + (* compiles parameters *) + let p_list = List.map (translate_pat env) p_list in + (* remove static computation from the body *) + (* and put it in the allocation place for stateful functions *) + let (static_code, init_code, body, result) = + if is_state + then + let static_code, body = static_block [] body in + let static_code, result = static static_code result in + let static_code = List.rev static_code in + (* translate the static code *) + let static_code, init_code = + translate_static_code env static_code in + (static_code, init_code, body, result) + else + ([], ([], []), body, result) in + (* then translate the body *) + let init_code, body = translate_block env init_code body in + let init_code, result = translate env init_code result in + init, + co_fun env is_state params p_list static_code init_code body result + | Dprim(g, e_list) -> + (* pointwise application *) + let init, ce_list = translate_list env init e_list in + init, Capply(Cglobal(g), ce_list) + | Dconstruct(g, e_list) -> + let init, ce_list = translate_list env init e_list in + init, Cconstruct(g, ce_list) + | Drecord(gl_expr_list) -> + let translate_record (gl, expr) (init, gl_expr_list) = + let init, ce = translate env init expr in + init, (gl, ce) :: gl_expr_list in + let init, l = + List.fold_right translate_record gl_expr_list (init, []) in + init, Crecord(l) + | Drecord_access(expr, gl) -> + let init, ce = translate env init expr in + init, Crecord_access(ce, gl) + | Difthenelse(e0, e1, e2) -> + let init, c0 = translate env init e0 in + let init, c1 = translate env init e1 in + let init, c2 = translate env init e2 in + init, Cifthenelse(c0, c1, c2) + | Dlet(block, e_let) -> + let env = push block env in + let init, code = translate_block env init block in + let init, ce = translate env init e_let in + init, clet code ce + | Dapply(is_state, { d_desc = Dvar(f, subst) }, l) -> + let f = translate_var env f in + let init, l = translate_list env init l in + let init, subst = translate_subst env init subst in + co_apply env is_state init f subst l + | Dapply(is_state, f, l) -> + let init, f = translate env init f in + let init, l = translate_list env init l in + co_apply env is_state init f [] l + | Deseq(e1, e2) -> + let init, e1 = translate env init e1 in + let init, e2 = translate env init e2 in + init, Cseq [e1; e2] + | Dwhen(e1) -> + translate env init e1 + | Dclock(ck) -> + translate_clock env init ck + | Dlast _ | Dinit _ | Dpre _ | Dtest _ -> + (* this case should not arrive *) + fatal_error "translate" + +and translate_list env init l = + match l with + [] -> init, [] + | ce :: l -> + let init, ce = translate env init ce in + let init, l = translate_list env init l in + init, ce :: l + +and translate_block env init b = + (* allocate the memory in the initialisation part *) + let init = allocate_memory env init in + (* compiles the body *) + let init, code = translate_equation env init [] b.b_equations in + (* sets code in the correct order *) + let code = List.rev code in + (* returns the components of the block *) + init, code + +(* the input equations must be already scheduled *) +and translate_equations env init code eq_list = + match eq_list with + [] -> init, code + | eq :: eq_list -> + let init, code = translate_equation env init code eq in + translate_equations env init code eq_list + +and translate_equation_into_exp env init eq = + let init, code = translate_equation env init [] eq in + (* sets code in the correct order *) + let code = List.rev code in + init, cseq code + +and translate_block_into_exp env init block = + let init, code = translate_block env init block in + init, cseq code + +and translate_equation env init code eq = + match eq with + Dget(pat, v) -> + let cpat = translate_pat env pat in + let n = translate_var env v in + init, Tlet(cpat, n) :: code + | Dequation(Dvarpat(n), e) when is_a_write (find env n) -> + let name = string_of_name env n in + let init, ce = translate env init e in + init, (set name ce) :: code + | Dequation(pat, e) | Dstatic(pat, e) -> + let is_rec = is_recursive pat e in + let pat = translate_pat env pat in + let init, ce = translate env init e in + init, if is_rec then Tletrec([pat, ce]) :: code + else Tlet(pat, ce) :: code + | Dwheneq(eq, ck) -> + let init, ce = translate_equation_into_exp env init eq in + let init, ck_ce = translate_clock env init ck in + init, Texp(ifthen ck_ce ce) :: code + | Dmerge(is_static, e, p_block_list) -> + let init, ce = translate env init e in + let init, l = translate_pat_block_list env init p_block_list in + init, merge code ce l + | Dnext(n, e) -> + (* n is either a memo or an initialisation variable *) + let init, ce = translate env init e in + init, (next (selfstate env) (string_of_name env n) ce) :: code + | Dseq(eq_list) | Dpar(eq_list) -> + translate_equations env init code eq_list + | Dblock(block) -> + translate_block env init block + | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ -> + (* these cases should not arrive since control structures have *) + (* been translated into the basic kernel *) + fatal_error "translate_equation" + +(* compilation of pattern matching *) +and translate_pat_block_list env init p_block_list = + (* compile one handler *) + let translate_pat_block init (pat, block) = + let env = push block env in + let cpat = translate_pat env pat in + let init, ce = translate_block_into_exp env init block in + init, (cpat, ce) in + match p_block_list with + [] -> init, [] + | pat_block :: pat_block_list -> + let init, pat_ce = translate_pat_block init pat_block in + let init, pat_ce_list = + translate_pat_block_list env init pat_block_list in + init, pat_ce :: pat_ce_list + +(* translate a pure (stateless) expression *) +and translate_pure env e = + let init, ce = translate env ([], []) e in + assert (init = ([], [])); + ce + +(* computes extra parameters for clock abstraction *) +and translate_forall env params = + let p_clocks = + List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in + let p_carriers = + List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in + p_clocks @ p_carriers + +(* generates an application for clock instanciation *) +and translate_subst env init subst = + let rec translate_clock_list init cl_list = + match cl_list with + [] -> init, [] + | cl :: cl_list -> + let init, cl = translate_clock env init cl in + let init, cl_list = translate_clock_list init cl_list in + init, cl :: cl_list in + let rec translate_carrier_list init car_list = + match car_list with + [] -> init, [] + | car :: car_list -> + let init, car = translate_carrier env init car in + let init, car_list = translate_carrier_list init car_list in + init, car :: car_list in + let init, cl_list = translate_clock_list init subst.s_clock in + let init, car_list = translate_carrier_list init subst.s_carrier in + init, cl_list @ car_list + +(* Initialisation code *) +and allocate_memory env init = + let allocate _ ident (acc_write, acc_mem) = + match ident.id_kind with + Kmemo -> + (* we allocate only one cell *) + let default = default_value env ident in + acc_write, (memo ident.id_name, default) :: acc_mem + | Kinit -> + (* init variables are considered to be state variables *) + acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem + | _ when is_a_write ident -> + (* local write variables are allocated too *) + (* but they will be stored in a stack allocated structure *) + let name = string_of_name env ident.id_name in + let default = default_value env ident in + (name, default) :: acc_write, acc_mem + | _ -> acc_write, acc_mem in + Hashtbl.fold allocate (cblock env).b_env init + +(* add static code into the initialisation part *) +and translate_static_code env static_code = + (* add one equation *) + (* we compute the list of introduced names and compile the equation *) + let translate_eq acc (pat, e) = + let acc = fv_pat acc pat in + let pat = translate_pat env pat in + let ce = translate_pure env e in + acc, Tlet(pat, ce) in + let rec translate_static_code acc static_code = + match static_code with + [] -> acc, [] + | pat_e :: static_code -> + let acc, cpat_ce = translate_eq acc pat_e in + let acc, static_code = translate_static_code acc static_code in + acc, cpat_ce :: static_code in + (* introduced names must be added to the memory *) + let intro acc_mem n = + let v = string_of_name env n in + (* modify the kind of [n] *) + set_static (find env n); + (string_of_name env n, Cvar(v)) :: acc_mem in + + (* first compile the static code *) + let acc, static_code = translate_static_code [] static_code in + (* introduced names must be added to the memory initialisation *) + let acc_mem = List.fold_left intro [] acc in + static_code, ([], acc_mem) + +(* default value *) +and default_value env ident = + (* find a value from a type *) + let rec value ty = + match ty with + Dproduct(ty_l) -> Ctuple(List.map value ty_l) + | Dbase(b) -> + let v = match b with + Dtyp_bool -> Cbool(false) + | Dtyp_int -> Cint(0) + | Dtyp_float -> Cfloat(0.0) + | Dtyp_unit -> Cvoid + | Dtyp_char -> Cchar(' ') + | Dtyp_string -> Cstring("") in + Cconstant(v) + | Dsignal(ty) -> Ctuple[value ty; cfalse] + | Dtypvar _ | Darrow _ -> cdummy + | Dconstr(qualid, _) -> + try + let desc = find_type qualid in + match desc.d_type_desc with + Dabstract_type -> cdummy + | Dabbrev(ty) -> + value ty + | Dvariant_type l -> + let case = List.hd l in + begin match case with + (qual, { arg = ty_l }) -> + Cconstruct(qual, List.map value ty_l) + end + | Drecord_type l -> + let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in + Crecord (List.map field_of_type l) + with + Not_found -> cdummy in + let value (Dtypforall(_, ty)) = value ty in + match ident.id_value with + None -> value ident.id_typ + | Some(e) -> translate_pure env e + +(** Compilation of a table of declarative code *) +let translate table = + let translate (s, e) = (s, translate_pure empty_env e) in + (* introduce the type of states *) +(* intro_state_type (); *) + (* then translate *) + (* translate the code *) + { c_types = table.d_types; + c_code = List.map translate table.d_code; + c_vars = table.d_vars; + } diff --git a/compiler/obc/ml/declarative.ml b/compiler/obc/ml/declarative.ml new file mode 100644 index 0000000..ae6db9e --- /dev/null +++ b/compiler/obc/ml/declarative.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: declarative.ml,v 1.18 2007-01-11 07:35:53 pouzet Exp $ *) +(* the intermediate format *) + +open Misc +open Names + +(* one set of (unique) names *) +type name = int + +type global = + Gname of string * name + | Gmodname of qualified_ident + +(* type definitions *) +type type_definition = + { d_type_desc: type_components; + d_type_arity: int list + } + +and ('a, 'b) ptyp = { arg: 'a; res: 'b } + +and type_components = + Dabstract_type + | Dabbrev of typ + | Dvariant_type of (qualified_ident * (typ list, typ) ptyp) list + | Drecord_type of (qualified_ident * is_mutable * (typ, typ) ptyp) list + +and is_mutable = bool + +(* types *) +and typs = Dtypforall of name list * typ +and typ = + | Darrow of is_node * typ * typ + | Dproduct of typ list + | Dconstr of qualified_ident * typ list + | Dtypvar of name + | Dbase of base_typ + | Dsignal of typ + +and is_node = bool + +and base_typ = + Dtyp_bool | Dtyp_int | Dtyp_float | Dtyp_unit | + Dtyp_char | Dtyp_string + +type guard = clock + +and clock = + | Dfalse (* the false clock *) + | Dtrue (* the base clock *) + | Don of bool * clock * carrier (* "cl on c" or "cl on not c" *) + | Dclockvar of name (* 'a *) + +and carrier = + Dcfalse + | Dctrue + | Dcvar of name + | Dcglobal of qualified_ident * name option * clock + (* identifier, reset name and clock *) + +(* immediate values *) +type immediate = + | Dbool of bool + | Dint of int + | Dfloat of float + | Dchar of char + | Dstring of string + | Dvoid + +type 'a desc = + { d_desc: 'a; + d_ty: typ; + d_guard: guard + } + +(* patterns *) +type pattern = + | Dwildpat + | Dvarpat of name + | Dconstantpat of immediate + | Dtuplepat of pattern list + | Dconstructpat of qualified_ident * pattern list + | Drecordpat of (qualified_ident * pattern) list + | Daliaspat of pattern * name + | Dorpat of pattern * pattern + +(* signal expressions *) +type spattern = + | Dandpat of spattern * spattern + | Dexppat of expr + | Dcondpat of expr * pattern + +(* expressions *) +and expr = expr_desc desc + +and expr_desc = + | Dconstant of immediate + | Dvar of var * subst + | Dlast of name + | Dpre of expr option * expr + | Difthenelse of expr * expr * expr + | Dinit of clock * name option + | Dtuple of expr list + | Dconstruct of qualified_ident * expr list + | Drecord of (qualified_ident * expr) list + | Drecord_access of expr * qualified_ident + | Dprim of qualified_ident * expr list + | Dfun of is_state * params * pattern list * block * expr + | Dapply of is_state * expr * expr list + | Dlet of block * expr + | Deseq of expr * expr + | Dtest of expr (* testing the presence "?" *) + | Dwhen of expr (* instruction "when" *) + | Dclock of clock + +and is_state = bool + +and var = + | Dlocal of name + | Dglobal of qualified_ident + +and is_external = bool (* true for imported ML values *) + +(* type and clock instance *) +and ('a, 'b, 'c) substitution = + { s_typ: 'a list; + s_clock: 'b list; + s_carrier: 'c list } + +and subst = (typ, clock, carrier) substitution +and params = (name, name, name) substitution + +(* block *) +and block = + { b_env: (name, ident) Hashtbl.t; (* environment *) + mutable b_write: name list; (* write variables *) + b_equations: equation; (* equations *) + } + +(* equation *) +and equation = + Dequation of pattern * expr (* equation p = e *) + | Dnext of name * expr (* next x = e *) + | Dlasteq of name * expr (* last x = e *) + | Demit of pattern * expr (* emit pat = e *) + | Dstatic of pattern * expr (* static pat = e *) + | Dget of pattern * var (* pat = x *) + | Dwheneq of equation * guard (* eq when clk *) + | Dmerge of is_static * expr (* control structure *) + * (pattern * block) list + | Dreset of equation * expr (* reset *) + | Dautomaton of clock * (state_pat * block * block * escape * escape) list + (* automaton weak and strong *) + | Dpar of equation list (* parallel equations *) + | Dseq of equation list (* sequential equations *) + | Dblock of block (* block structure *) + | Dpresent of clock * (spattern * block) list * block + (* presence testing *) + +and escape = (spattern * block * is_continue * state) list + +and is_static = bool +and is_strong = bool +and is_continue = bool + +and state_pat = string * pattern list +and state = string * expr list + +(* ident definition *) +and ident = + { id_name: name; (* its name (unique identifier) *) + id_original: string option; (* its original name when possible *) + id_typ: typs; (* its type *) + id_value: expr option; (* its initial value when possible *) + mutable id_kind: id_kind; (* kind of identifier *) + mutable id_write: bool; (* physically assigned or not *) + mutable id_last: bool; (* do we need its last value also? *) + mutable id_signal: bool; (* is-it a signal? *) + } + +(* a local variable in a block may be of four different kinds *) +and id_kind = + Kinit (* initialisation state variable *) + | Kclock (* clock variable *) + | Kreset (* reset variable *) + | Kmemo (* state variable *) + | Kstatic (* static variable *) + | Klast (* last variable *) + | Kvalue (* defined variable *) + | Kshared (* shared variable with several definitions *) + | Kinput (* input variable, i.e, argument *) + +(* global definition *) +(* Invariant: expr must be bounded and static *) + +(* the declarative code associated to a file *) +type declarative_code = + { mutable d_modname: string; (* module name *) + mutable d_types: (string, type_definition) Hashtbl.t; + (* type definitions *) + mutable d_code: (string * expr) list; (* value definitions *) + mutable d_vars: string list; (* defined names *) + } + + +(* the generated code of a module *) +let dc = { d_modname = ""; + d_types = Hashtbl.create 7; + d_code = []; + d_vars = [] + } + +let code () = dc + +(* thing to do when starting the production of declarative code *) +(* for a file *) +let start modname = + dc.d_modname <- modname; + dc.d_types <- Hashtbl.create 7; + dc.d_code <- []; + dc.d_vars <- [] + +(* things to do at the end of the front-end*) +let finish () = + dc.d_code <- List.rev dc.d_code + +(* apply a function to every value *) +let replace translate = + let rec replace (s, e) = + let e = translate e in + dc.d_code <- (s, e) :: dc.d_code in + let code = dc.d_code in + dc.d_code <- []; + List.iter replace code; + dc.d_code <- List.rev dc.d_code + + +(* add an input to the declarative code *) +let add_dec (name, code) = + dc.d_code <- (name, code) :: dc.d_code; + dc.d_vars <- name :: dc.d_vars + +(* add a type definition to the declarative code *) +let add_type (name, type_def) = + Hashtbl.add dc.d_types name type_def + +(* read code from and write code into a file *) +let read_declarative_code ic = input_value ic + +let write_declarative_code oc = + output_value oc (code ()) + +(* the list of opened modules *) +let dc_modules = (Hashtbl.create 7 : (string, declarative_code) Hashtbl.t) + +(* add a module to the list of opened modules *) +let add_module m = + let name = String.uncapitalize m in + try + let fullname = find_in_path (name ^ ".dcc") in + let ic = open_in fullname in + let dc = input_value ic in + Hashtbl.add dc_modules m dc; + close_in ic; + dc + with + Cannot_find_file _ -> + Printf.eprintf + "Cannot find the compiled declarative file %s.dcc.\n" + name; + raise Error + +let find_value qualid = + let dc = + if qualid.qual = dc.d_modname then dc + else raise Not_found +(* + try + Hashtbl.find dc_modules qualid.qual + with + Not_found -> add_module qualid.qual *) in + List.assoc qualid.id dc.d_code + +let find_type qualid = + if qualid.qual = dc.d_modname then Hashtbl.find dc.d_types qualid.qual + else raise Not_found diff --git a/compiler/obc/ml/declarative_printer.ml b/compiler/obc/ml/declarative_printer.ml new file mode 100644 index 0000000..6c93d2c --- /dev/null +++ b/compiler/obc/ml/declarative_printer.ml @@ -0,0 +1,699 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: declarative_printer.ml,v 1.13 2007-01-11 07:35:53 pouzet Exp $ *) + +open Misc +open Names +open Declarative +open Modules +open Format + +(* generic printing of a list *) +let print_list print l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + print x; + print_space (); + printrec l in + printrec l + +(* local name *) +let print_name i = + print_string "/";print_int i + +(* global names *) +let print_qualified_ident { qual = q; id = id } = + if (q = pervasives_module) or (q = compiled_module_name ()) + or (q = "") + then print_string id + else + begin + print_string q; + print_string "."; + print_string id + end + +(* print types *) +let rec print_type typ = + open_box 1; + begin match typ with + Darrow(is_node, typ1, typ2) -> + print_string "("; + if is_node then print_string "=>" else print_string "->"; + print_space (); + print_list print_type [typ1;typ2]; + print_string ")" + | Dproduct(ty_list) -> + print_string "("; + print_string "*"; + print_space (); + print_list print_type ty_list; + print_string ")" + | Dconstr(qual_ident, ty_list) -> + if ty_list <> [] then print_string "("; + print_qualified_ident qual_ident; + if ty_list <> [] then + begin print_space (); + print_list print_type ty_list; + print_string ")" + end + | Dsignal(ty) -> print_type ty; print_space (); print_string "sig" + | Dtypvar(i) -> print_int i + | Dbase(b) -> print_base_type b + end; + close_box () + +and print_base_type b = + match b with + Dtyp_bool -> print_string "bool" + | Dtyp_int -> print_string "int" + | Dtyp_float -> print_string "float" + | Dtyp_unit -> print_string "unit" + | Dtyp_string -> print_string "string" + | Dtyp_char -> print_string "char" + +let print_typs (Dtypforall(l, typ)) = + match l with + [] -> (* we do not print the quantifier when there is no type variable *) + print_type typ + | l -> + open_box 1; + print_string "(forall"; + print_space (); + print_list print_name l; + print_space (); + print_type typ; + print_string ")"; + close_box () + +(* print clocks *) +let rec print_clock clk = + match clk with + | Dfalse -> print_string "false" + | Dtrue -> print_string "true" + | Dclockvar(i) -> print_name i + | Don(b, clk, c) -> + print_string "("; + if b then print_string "on" else print_string "onot"; + print_space (); + print_clock clk; + print_space (); + print_carrier c; + print_string ")" +and print_carrier c = + match c with + Dcfalse -> print_string "false" + | Dctrue -> print_string "true" + | Dcvar(i) -> print_name i + | Dcglobal(qual_ident, res, clk) -> + print_qualified_ident qual_ident; + print_string "("; + (match res with + None -> () + | Some(n) -> print_space ();print_name n;print_space ()); + print_clock clk; + print_string ")" + +(* immediate values *) +let print_immediate i = + match i with + Dbool(b) -> print_string (if b then "true" else "false") + | Dint(i) -> print_int i + | Dfloat(f) -> print_float f + | Dchar(c) -> print_char c + | Dstring(s) -> print_string s + | Dvoid -> print_string "()" + +(* print patterns *) +let atom_pat pat = + match pat with + Dconstantpat _ | Dvarpat _ | Dwildpat -> true + | _ -> false + +let rec print_pat pat = + open_box 1; + if not (atom_pat pat) then print_string "("; + begin match pat with + Dwildpat -> print_string "_" + | Dconstantpat(i) -> print_immediate i + | Dvarpat(i) -> print_name i + | Dconstructpat(qual_ident, pat_list) -> + print_string "constr"; + print_space (); + print_qualified_ident qual_ident; + if pat_list <> [] then print_space (); + print_list print_pat pat_list + | Dtuplepat(pat_list) -> + print_string ","; + print_space (); + print_list print_pat pat_list + | Drecordpat(l) -> + print_string "record"; + print_list + (fun (qual_ident, pat) -> + open_box 1; + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print_pat pat; + print_string ")"; + close_box ()) l + | Dorpat(pat1, pat2) -> + print_string "orpat"; + print_space (); + print_list print_pat [pat1;pat2] + | Daliaspat(pat, i) -> + print_string "as"; + print_space (); + print_pat pat; + print_space (); + print_int i + end; + if not (atom_pat pat) then print_string ")"; + close_box () + +(* print statepat *) +let print_statepat (s, l) = + match l with + [] -> print_string s + | l -> print_string "("; + print_string s; + print_space (); + print_list print_pat l; + print_string ")" + +(* print expressions *) +let atom e = + match e.d_desc with + Dconstant _ -> true + | _ -> false + +(* print variables *) +let print_var v = + match v with + Dlocal(n) -> + print_string "local"; + print_space (); + print_name n + | Dglobal(qual_ident) -> + print_string "global"; + print_space (); + print_qualified_ident qual_ident + +let rec print e = + open_box 1; + if not (atom e) then print_string "("; + begin match e.d_desc with + Dconstant(i) -> print_immediate i + | Dvar(v, subst) -> + print_var v; + print_subst subst + | Dlast(i) -> + print_string "last"; + print_space (); + print_name i + | Dpre(opt_default, e) -> + print_string "pre"; + print_space (); + begin match opt_default with + None -> print e + | Some(default) -> + print default; print_space (); print e + end + | Dinit(ck, None) -> + print_string "init"; + print_space (); + print_clock ck + | Dinit(ck, Some(n)) -> + print_string "init"; + print_space (); + print_clock ck; + print_space (); + print_name n + | Difthenelse(e0,e1,e2) -> + print_string "if"; + print_space (); + print e0; + print_space (); + print e1; + print_space (); + print e2 + | Dtuple(l) -> + print_string ","; + print_space (); + print_list print l + | Dconstruct(qual_ident,l) -> + print_string "constr"; + print_space (); + print_qualified_ident qual_ident; + if l <> [] then print_space (); + print_list print l + | Dprim(qual_ident, l) -> + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print_list print l; + print_string ")" + | Drecord(l) -> + print_string "record"; + print_space (); + print_list (fun (qual_ident, e) -> + open_box 1; + print_string "("; + print_qualified_ident qual_ident; + print_space (); + print e; + print_string ")"; + close_box ()) l + | Drecord_access(e,qual_ident) -> + print_string "access"; + print_space (); + print e; + print_space (); + print_qualified_ident qual_ident + | Dfun(is_state, params, args, block, e) -> + print_string ("fun" ^ (if is_state then "(s)" else "(c)")); + print_space (); + print_params params; + print_space (); + print_list print_pat args; + print_space (); + print_block block; + print_space (); + print_string "return "; + print e + | Dapply(is_state, f, e_list) -> + print_string ("apply" ^ (if is_state then "(s)" else "(c)")); + print_space (); + print f; + print_space (); + print_list print e_list + | Dlet(block, e) -> + print_string "let"; + print_space (); + print_block block; + print_space (); + print e + | Deseq(e1, e2) -> + print_string "seq"; + print_space (); + print e1; + print_space (); + print e2 + | Dtest(e1) -> + print_string "test"; + print_space (); + print e1 + | Dwhen(e1) -> + print_string "when"; + print_space (); + print e1 + | Dclock(ck) -> + print_string "clock"; + print_space (); + print_clock ck + end; + if not (atom e) then print_string ")"; + close_box() + +and print_block b = + (* print variable definitions *) + let print_env env = + open_box 1; + print_string "(env"; + print_space (); + Hashtbl.iter (fun i ident -> print_ident ident;print_space ()) env; + print_string ")"; + close_box () in + (* main function *) + open_box 1; + print_string "("; + (* environment *) + print_env b.b_env; + print_space (); + (* equations *) + print_equation b.b_equations; + print_space (); + (* write variables *) + print_string "(write"; + print_space (); + print_list print_name b.b_write; + print_string ")"; + print_string ")"; + close_box () + +(* print ident declarations *) +(* e.g, "(kind x/412 (int) (cl) (write) (last) (signal) (= 412))" *) +and print_ident id = + let print_kind () = + match id.id_kind with + Kinit -> print_string "init" + | Kclock -> print_string "clock" + | Kmemo -> print_string "memo" + | Kstatic -> print_string "static" + | Klast -> print_string "last" + | Kreset -> print_string "reset" + | Kvalue -> print_string "value" + | Kinput -> print_string "input" + | Kshared -> print_string "shared" in + let print_name () = + begin match id.id_original with + None -> () + | Some(s) -> print_string s + end; + print_name id.id_name in + let print_typs () = + print_string "("; + print_typs id.id_typ; + print_string ")" in + let print_write () = + if id.id_write then + begin print_space (); print_string "(write)" end in + let print_last () = + if id.id_last then + begin print_space (); print_string "(last)" end in + let print_signal () = + if id.id_signal then + begin print_space (); print_string "(signal)" end in + let print_expr () = + match id.id_value with + None -> () + | Some(e) -> + print_space ();print_string "(= "; print e; print_string ")" in + (* main function *) + open_box 1; + print_string "("; + print_kind (); + print_space (); + print_name (); + print_space (); + print_typs (); + print_space (); + print_write (); + print_last (); + print_signal (); + print_expr (); + print_string ")"; + close_box () + +(* prints a sequence of sets of parallel equations *) +and print_equation eq = + open_box 1; + print_string "("; + begin match eq with + Dequation(pat, e) -> + print_string "let"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dlasteq(n, e) -> + print_string "last"; + print_space (); + print_name n; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Demit(pat, e) -> + print_string "emit"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dstatic(pat, e) -> + print_string "static"; + print_space (); + print_pat pat; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dnext(n, e) -> + print_string "next"; + print_space (); + print_name n; + print_space (); + print e; + print_space (); + print_clock e.d_guard + | Dget(pat, v) -> + print_string "get"; + print_space (); + print_pat pat; + print_space (); + print_var v + | Dwheneq(eq, clk) -> + print_string "when"; + print_space (); + print_clock clk; + print_space (); + print_equation eq + | Dmerge(is_static, e, pat_block_list) -> + print_string "merge"; + print_space (); + if is_static then print_string "static" + else print_clock e.d_guard; + print_space (); + print e; + print_space (); + print_list (fun (pat, block) -> + open_box 1; + print_string "("; + print_pat pat; + print_space (); + print_block block; + print_string ")"; + close_box ()) pat_block_list + | Dpresent(ck, scondpat_block_list, block) -> + print_string "present"; + print_space (); + print_clock ck; + print_space (); + print_list (fun (scondpat, block) -> + open_box 1; + print_string "("; + print_spat scondpat; + print_space (); + print_block block; + print_string ")"; + close_box ()) scondpat_block_list; + print_space (); + print_block block + | Dreset(eq, e) -> + print_string "reset"; + print_space (); + print_equation eq; + print_space (); + print e + | Dautomaton(ck, handlers) -> + print_string "automaton"; + print_space (); + print_clock ck; + print_space (); + print_list print_handler handlers + | Dpar(eq_list) -> + print_string "par"; + print_space (); + print_list print_equation eq_list + | Dseq(eq_list) -> + print_string "seq"; + print_space (); + print_list print_equation eq_list + | Dblock(b) -> + print_string "block"; + print_space (); + print_block b + end; + print_string ")"; + close_box () + +(* print the handlers of an automaton *) +and print_handler (statepat, b_weak, b_strong, weak_escape, strong_escape) = + open_box 1; + print_string "(state"; + print_space (); + print_statepat statepat; + print_space (); + print_block b_weak; + print_space (); + print_block b_strong; + print_space (); + print_string "(weak "; + print_escape weak_escape; + print_string ")"; + print_space (); + print_string "(strong "; + print_escape weak_escape; + print_string ")"; + print_string ")"; + close_box () + +and print_escape escape_list = + print_list + (fun (spat, b, is_continue, state) -> + print_string "("; + if is_continue then print_string "continue " else print_string "then "; + print_spat spat; + print_space (); + print_block b; + print_space (); + print_state state; + print_string ")") + escape_list; + close_box () + + +(* print type and clock instance *) +and print_subst { s_typ = st; s_clock = scl; s_carrier = sc } = + match st, scl, sc with + [],[],[] -> () + | l1,l2,l3 -> + print_string "["; + print_list print_type l1; + print_string "]"; + print_space (); + print_string "["; + print_list print_clock l2; + print_string "]"; + print_space (); + print_string "["; + print_list print_carrier l3; + print_string "]"; + +and print_params { s_typ = pt; s_clock = pcl; s_carrier = pc } = + match pt, pcl, pc with + [],[],[] -> () + | l1,l2,l3 -> + print_string "["; + print_list print_name l1; + print_string "]"; + print_space (); + print_string "["; + print_list print_name l2; + print_string "]"; + print_space (); + print_string "["; + print_list print_name l3; + print_string "]" + +and print_state (s, l) = + match l with + [] -> print_string s + | l -> print_string "("; + print_string s; + print_space (); + print_list print l; + print_string ")" + +and atom_spat spat = + match spat with + Dexppat _ | Dcondpat _ -> true + | _ -> false + +and print_spat spat = + open_box 1; + if not (atom_spat spat) then print_string "("; + begin match spat with + Dandpat(spat1, spat2) -> + print_string "& "; + print_spat spat1; + print_space (); + print_spat spat2 + | Dexppat(e) -> + print e + | Dcondpat(e, pat) -> + print_string "is "; + print e; + print_space (); + print_pat pat + end; + if not (atom_spat spat) then print_string ")"; + close_box () + +(* the main entry for printing definitions *) +let print_definition (name, e) = + open_box 2; + print_string "(def "; + if is_an_infix_or_prefix_operator name + then begin print_string "( "; print_string name; print_string " )" end + else print_string name; + print_space (); + print e; + print_string ")"; + print_newline (); + close_box () + +(* print types *) +let print_variant (qualid, { arg = typ_list; res = typ }) = + print_string "("; + print_qualified_ident qualid; + print_string "("; + print_list print_type typ_list; + print_string ")"; + print_space (); + print_type typ; + print_string ")" + +let print_record (qualid, is_mutable, { arg = typ1; res = typ2 }) = + print_string "("; + if is_mutable then print_string "true" else print_string "false"; + print_space (); + print_qualified_ident qualid; + print_space (); + print_type typ1; + print_space (); + print_type typ2; + print_string ")" + +let print_type_declaration s { d_type_desc = td; d_type_arity = arity } = + open_box 2; + print_string "(type["; + print_list print_name arity; + print_string "]"; + print_space (); + print_string s; + print_space (); + begin match td with + Dabstract_type -> () + | Dabbrev(ty) -> + print_type ty + | Dvariant_type variant_list -> + List.iter print_variant variant_list + | Drecord_type record_list -> + List.iter print_record record_list + end; + print_string ")"; + print_newline (); + close_box ();; + +(* the main functions *) +set_max_boxes max_int ;; + +let output_equations oc eqs = + set_formatter_out_channel oc; + List.iter print_equation eqs + +let output oc declarative_code = + set_formatter_out_channel oc; + (* print type declarations *) + Hashtbl.iter print_type_declaration declarative_code.d_types; + (* print value definitions *) + List.iter print_definition declarative_code.d_code; + print_flush () + diff --git a/compiler/obc/ml/default_value.ml b/compiler/obc/ml/default_value.ml new file mode 100644 index 0000000..ff2800a --- /dev/null +++ b/compiler/obc/ml/default_value.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Gregoire Hamon, Marc Pouzet *) +(* Organization : SPI team, LIP6 laboratory, University Paris 6 *) +(* *) +(**************************************************************************) + +(* $Id: default_value.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *) + +(** Computes a default value from a type *) + +open Misc +open Names +open Def_types +open Types +open Initialization +open Caml + +let default x ty = + let rec def ty = + match ty with + TypeVar{contents = Typindex _} -> Cdummy "" + | TypeVar{contents = Typlink ty} -> def ty + | Tarrow _ -> x + | Tproduct(t_list) -> + if t_list = [] + then Cdummy "" + else Ctuple (List.map def t_list) + | Tconstr (info, tlist) -> + if info.qualid.qual = pervasives_module then + match info.qualid.id with + | "int" -> Cim (Cint 0) + | "bool" | "clock" -> Cim (Cbool false) + | "float" -> Cim (Cfloat 0.0) + | "char" -> Cim (Cchar 'a') + | "string" -> Cim (Cstring "") + | "unit" -> Cim (Cvoid) + | _ -> Cdummy "" + else + match info.info_in_table.type_desc with + Abstract_type -> Cdummy "" + | Variant_type l -> + begin + let case = List.hd l in + match case.info_in_table.typ_desc with + Tarrow (ty1, ty2) -> + Cconstruct1 ({ cqual = case.qualid.qual; + cid = case.qualid.id }, def ty1) + | _ -> + Cconstruct0 { cqual = case.qualid.qual; + cid = case.qualid.id } + end + | Record_type l -> + let field_of_type x = + let ty1,_ = filter_arrow x.info_in_table.typ_desc in + ({ cqual = x.qualid.qual; cid = x.qualid.id }, def ty1) in + Crecord (List.map field_of_type l) + in + def ty + + diff --git a/compiler/obc/ml/misc.ml b/compiler/obc/ml/misc.ml new file mode 100644 index 0000000..ec719ac --- /dev/null +++ b/compiler/obc/ml/misc.ml @@ -0,0 +1,295 @@ +(**************************************************************************) +(* *) +(* Lucid Synchrone *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) + +(* $Id: misc.ml,v 1.11 2006-09-30 12:27:27 pouzet Exp $ *) + +(* version of the compiler *) +let version = "3.0b" + +let date = DATE + +(* standard module *) +let pervasives_module = "Pervasives" +let standard_lib = STDLIB + +(* variable creation *) +(* generating names *) +class name_generator = + object + val mutable counter = 0 + method name = + counter <- counter + 1; + counter + method reset = + counter <- 0 + method init i = + counter <- i + end + +(* association table with memoization *) +class name_assoc_table f = + object + val mutable counter = 0 + val mutable assoc_table: (int * string) list = [] + method name var = + try + List.assq var assoc_table + with + not_found -> + let n = f counter in + counter <- counter + 1; + assoc_table <- (var,n) :: assoc_table; + n + method reset = + counter <- 0; + assoc_table <- [] + end + +(* error during the whole process *) +exception Error + +(* internal error : for example, an abnormal pattern matching failure *) +(* gives the name of the function *) +exception Internal_error of string + +let fatal_error s = raise (Internal_error s) + +let not_yet_implemented s = + Printf.eprintf "The construction %s is not implemented yet.\n" s; + raise Error + +(* creating a name generator for type and clock calculus *) +(* ensure unicity for the whole process *) +let symbol = new name_generator + +(* generic and non generic variables in the various type systems *) +let generic = -1 +let notgeneric = 0 +let maxlevel = max_int + +let binding_level = ref 0 +let top_binding_level () = !binding_level = 0 + +let push_binding_level () = binding_level := !binding_level + 1 +let pop_binding_level () = + binding_level := !binding_level - 1; + assert (!binding_level > generic) +let reset_binding_level () = binding_level := 0 + +(* realtime mode *) +let realtime = ref false + +(* assertions *) +let no_assert = ref false + +(* converting integers into variable names *) +(* variables are printed 'a, 'b *) +let int_to_letter bound i = + if i < 26 + then String.make 1 (Char.chr (i+bound)) + else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26) + +let int_to_alpha i = int_to_letter 97 i + +(* printing information *) +class on_off = + object + val mutable status = false + method set = status <- true + method get = status + end + +let print_type = new on_off +let print_clock = new on_off +let print_init = new on_off +let print_causality = new on_off +let no_causality = ref false +let no_initialisation = ref false + +let no_deadcode = ref false + +(* control what is done in the compiler *) +exception Stop + +let only = ref "" +let set_only_info o = only := o +let parse_only () = + if !only = "parse" then raise Stop +let type_only () = + if !only = "type" then raise Stop +let clock_only () = + if !only = "clock" then raise Stop +let caus_only () = + if !only = "caus" then raise Stop +let init_only () = + if !only = "init" then raise Stop +let dec_only () = + if !only = "parse" or !only = "type" + or !only = "clock" or !only = "init" + or !only = "dec" then raise Stop + +(* load paths *) +let load_path = ref ([] : string list) + +(* no link *) +let no_link = ref false + +(* simulation node *) +let simulation_node = ref "" + +(* sampling rate *) +let sampling_rate : int option ref = ref None + +(* level of inlining *) +let inlining_level = ref 10 + +(* emiting declarative code *) +let print_declarative_code = ref false +let print_auto_declarative_code = ref false +let print_total_declarative_code = ref false +let print_last_declarative_code = ref false +let print_signals_declarative_code = ref false +let print_reset_declarative_code = ref false +let print_linearise_declarative_code = ref false +let print_initialize_declarative_code = ref false +let print_split_declarative_code = ref false +let print_inline_declarative_code = ref false +let print_constant_declarative_code = ref false +let print_deadcode_declarative_code = ref false +let print_copt_declarative_code = ref false + +(* total emission of signals *) +let set_total_emit = ref false + +(* generating C *) +let make_c_code = ref false + +(* profiling information about the compilation *) +let print_exec_time = ref false + +exception Cannot_find_file of string + +let find_in_path filename = + if Sys.file_exists filename then + filename + else if not(Filename.is_implicit filename) then + raise(Cannot_find_file filename) + else + let rec find = function + [] -> + raise(Cannot_find_file filename) + | a::rest -> + let b = Filename.concat a filename in + if Sys.file_exists b then b else find rest + in find !load_path + + +(* Prompts: [error_prompt] is printed before compiler error *) +(* and warning messages *) +let error_prompt = ">" + +(* list intersection *) +let intersect l1 l2 = + List.exists (fun el -> List.mem el l1) l2 + +(* remove an entry from an association list *) +let rec remove n l = + match l with + [] -> raise Not_found + | (m, v) :: l -> + if n = m then l else (m, v) :: remove n l + +(* list substraction. l1 - l2 *) +let sub_list l1 l2 = + let rec sl l l1 = + match l1 with + [] -> l + | h :: t -> sl (if List.mem h l2 then l else (h :: l)) t in + sl [] l1 + +(* union *) +let rec union l1 l2 = + match l1, l2 with + [], l2 -> l2 + | l1, [] -> l1 + | x :: l1, l2 -> + if List.mem x l2 then union l1 l2 else x :: union l1 l2 + +let addq x l = if List.memq x l then l else x :: l + +let rec unionq l1 l2 = + match l1, l2 with + [], l2 -> l2 + | l1, [] -> l1 + | x :: l1, l2 -> + if List.memq x l2 then unionq l1 l2 else x :: unionq l1 l2 + +(* intersection *) +let rec intersection l1 l2 = + match l1, l2 with + ([], _) | (_, []) -> [] + | x :: l1, l2 -> if List.mem x l2 then x :: intersection l1 l2 + else intersection l1 l2 + +(* the last element of a list *) +let rec last l = + match l with + [] -> raise (Failure "last") + | [x] -> x + | _ :: l -> last l + +(* iterator *) +let rec map_fold f acc l = + match l with + [] -> acc, [] + | x :: l -> + let acc, v = f acc x in + let acc, l = map_fold f acc l in + acc, v :: l + +(* flat *) +let rec flat l = + match l with + [] -> [] + | x :: l -> x @ flat l + +(* reverse *) +let reverse l = + let rec reverse acc l = + match l with + [] -> acc + | x :: l -> reverse (x :: acc) l in + reverse [] l + +(* generic printing of a list *) +let print_list print print_sep l = + let rec printrec l = + match l with + [] -> () + | [x] -> + print x + | x::l -> + print x; + print_sep (); + printrec l in + printrec l + +(* generates the sequence of integers *) +let rec from n = if n = 0 then [] else n :: from (n-1) + +(* for infix operators, print parenthesis around *) +let is_an_infix_or_prefix_operator op = + if op = "" then false + else + let c = String.get op 0 in + not (((c >= 'a') & (c <= 'z')) or ((c >= 'A') & (c <= 'Z'))) + +(* making a list from a hash-table *) +let listoftable t = + Hashtbl.fold (fun key value l -> (key, value) :: l) t [] diff --git a/compiler/obc/ml/ml.ml b/compiler/obc/ml/ml.ml new file mode 100644 index 0000000..139597f --- /dev/null +++ b/compiler/obc/ml/ml.ml @@ -0,0 +1,2 @@ + +