jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

ml files imported from lucy v3

Browse source
This commit is contained in:
Léonard Gérard 2011-01-11 14:25:50 +01:00
parent 315527231c
commit e9e8ca382a
10 changed files with 2881 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

98
compiler/obc/ml/caml.ml Normal file
View file

@ -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]

131
compiler/obc/ml/caml_aux.ml Normal file
View file

@ -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

404
compiler/obc/ml/caml_printer.ml Normal file
View file

@ -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 ()

46
compiler/obc/ml/cenvironment.ml Normal file
View file

@ -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

848
compiler/obc/ml/coiteration.ml Normal file
View file

@ -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.<init, code, res> 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;
}

295
compiler/obc/ml/declarative.ml Normal file
View file

@ -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

699
compiler/obc/ml/declarative_printer.ml Normal file
View file

@ -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 ()

63
compiler/obc/ml/default_value.ml Normal file
View file

@ -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

295
compiler/obc/ml/misc.ml Normal file
View file

@ -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 []

2
compiler/obc/ml/ml.ml Normal file
View file

@ -0,0 +1,2 @@