-
Erwan Jahier authored
(--inline-iterators) to activate it. nb : do not inline completely nested iterator calls (yet, cf TODO).
Erwan Jahier authored(--inline-iterators) to activate it. nb : do not inline completely nested iterator calls (yet, cf TODO).
lazyCompiler.ml 36.74 KiB
(** Time-stamp: <modified the 20/11/2008 (at 11:21) by Erwan Jahier> *)
open Lxm
open Errors
open SyntaxTree
open SyntaxTreeCore
open Eff
let finish_me msg = print_string ("\n\tXXX LazyCompiler:"^msg^" -> finish me!\n")
(******************************************************************************)
(** Returns the ident on which the recursion was detected, plus an execution
stack description.
*)
exception Recursion_error of (Ident.long as 'id) * (string list as 'stack)
exception BadCheckRef_error
let recursion_error (lxm : Lxm.t) (stack : string list) =
let rec string_of_stack = function
| [] -> "nostack"
| s::[] -> s
| s::l -> s^"\n > "^(string_of_stack l)
in
raise ( Compile_error (lxm,
"recursion loop detected:\n > "
^(string_of_stack stack)
))
(******************************************************************************)
(* Structure principale *)
type t = {
src_tab : SyntaxTab.t;
(* table des defs *)
types : (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t;
consts : (Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t;
nodes : (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t;
(* table des prov *)
prov_types : (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t;
prov_consts : (Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t;
prov_nodes : (Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t
}
(******************************************************************************)
(* exported *)
let (create : SyntaxTab.t -> t) =
fun tbl ->
{
src_tab = tbl;
types = Hashtbl.create 0;
consts = Hashtbl.create 0;
nodes = Hashtbl.create 0;
prov_types = Hashtbl.create 0;
prov_consts = Hashtbl.create 0;
prov_nodes = Hashtbl.create 0;
(* XXX il manque aussi une table pour les clocks !!! *)
}
(******************************************************************************)
(** Type checking + constant checking/evaluation
This is performed (lazily) by 10 mutually recursive functions:
checking types --------------
(1) [type_check env type_name lxm]: type check the type id [type_name]
(2) [type_check_do]: untabulated version of [type_check] (do the real work).
(3) [type_check_interface]: ditto, but for the interface part
(4) [type_check_interface_do]: untabulated version (do the real work)
(5) [solve_type_idref] solves constant reference (w.r.t. short/long ident)
checking constants
------------------
(6) [const_check env const_name lxm]: eval/check the constant [const_name]
(7) [const_check_do] : untabulated version (do the real work)
(8) [const_check_interface]: ditto, but for the interface part
(9) [const_check_interface_do]: untabulated version (do the real work)
(10) [solve_const_idref] solves constant reference (w.r.t. short/long ident)
checking nodes
--------------
(11) [node_check env node_name lxm]: check the node [node_name]
checking a node means checking its interface and checking it equations/asserts.
checking an equation means checking that the type and clock of the
left part is the same as the ones of the rigth part.
(12) [node_check_do] : untabulated version (do the real work)
(13) [node_check_interface]: ditto, but for the interface part
(14) [node_check_interface_do]: untabulated version (do the real work)
(15) [solve_node_idref] solves constant reference (w.r.t. short/long ident)
XXX checking clocks
-------------------
Ditto, but todo!
nb: for x in {type, const, node, clock}, there are several functions
that returns [x_eff]:
- [x_check]
o tabulates its result
o takes an x_key and returns an [x_eff]
o lookups its (syntaxic) definition (x_info) via the symbolTab.t
o calls [GetEff.X] to translate its sub-terms
- [GetEff.X]
o takes a [x_exp] (i.e., an expression) and returns an [x_eff]
o compute the effective static args (for nodes)
o calls [solve_x_idref] (via [id_solver]) to translate its sub-terms
- [solve_x_idref]
o takes an idref (plus a Eff.static_arg list for x=node!)
o perform name resolution
o calls [x_check] (loop!)
nb2: the top-level call is [node_check], on a node that necessarily contains
no static parameters.
*)
(* Before starting, let's define a few utilitary functions. *)
(** Intermediary results are put into a table. This tabulation handling
is common to type and constant checking, and is performed by the 2 following functions.
Since [x] is meant to stand for [type], [const], or [node], those 2
functions will lead to the definition of 6 functions:
[type_check], [const_check], [node_check],
[type_check_interface], [const_check_interface], [node_check_interface].
*)
let x_check
tab find_x x_check_do lookup_x_eff pack_of_x_key name_of_x_key this x_key lxm =
try lookup_x_eff tab x_key lxm
with Not_found ->
Hashtbl.add tab x_key Eff.Checking;
let (x_pack,xn) = (pack_of_x_key x_key, name_of_x_key x_key) in
let x_pack_symbols = SyntaxTab.pack_body_env this.src_tab x_pack in
let x_def = match find_x x_pack_symbols xn lxm with
| SymbolTab.Local x_def -> x_def
| SymbolTab.Imported (lid,_) ->
print_string ("*** " ^ (Ident.string_of_long lid) ^ "???\n" ^
(Lxm.details lxm));
assert false (* should not occur *)
in
let res = x_check_do this x_key lxm x_pack_symbols false x_pack x_def in
Hashtbl.replace tab x_key (Eff.Checked res);
res
let x_check_interface
tab find_x x_check x_check_interface_do lookup_x_eff
pack_of_x_key name_of_x_key this x_key lxm =
try lookup_x_eff tab x_key lxm
with Not_found ->
Hashtbl.add tab x_key Eff.Checking;
let (xp,xn) = (pack_of_x_key x_key, name_of_x_key x_key) in
let xp_prov_symbols_opt = SyntaxTab.pack_prov_env this.src_tab xp lxm in
let res = (* [xp] migth have no provided symbol table *)
match xp_prov_symbols_opt with
| None ->
(* if [xp] have no provided symbol table, the whole package is exported. *)
x_check this x_key lxm
| Some xp_prov_symbols ->
let x_def = match find_x xp_prov_symbols xn lxm with
| SymbolTab.Local x -> x
| SymbolTab.Imported _ -> assert false (* should not occur *)
in
x_check_interface_do this x_key lxm xp_prov_symbols xp x_def
in
Hashtbl.replace tab x_key (Eff.Checked res);
res
(* Returns the tabulated [type] or [const], if it has already been computed;
otherwise, raise [Not_found] otherwise. *)
let lookup_x_eff x_label id_of_x_key x_tab x_key lxm =
match Hashtbl.find x_tab x_key with
| Eff.Checked res -> res
| Eff.Checking ->
raise (Recursion_error (id_of_x_key x_key, [x_label^(Lxm.details lxm)]))
| Eff.Incorrect -> raise (BadCheckRef_error)
let (lookup_type_eff: (Eff.item_key, Eff.type_ Eff.check_flag) Hashtbl.t ->
Ident.long -> Lxm.t -> Eff.type_) =
lookup_x_eff "type ref " (fun k -> k)
let (lookup_const_eff:(Eff.item_key, Eff.const Eff.check_flag) Hashtbl.t ->
Ident.long -> Lxm.t -> Eff.const) =
lookup_x_eff "const ref " (fun k -> k)
let (lookup_node_exp_eff:
(Eff.node_key, Eff.node_exp Eff.check_flag) Hashtbl.t ->
Eff.node_key -> Lxm.t -> Eff.node_exp) =
lookup_x_eff "node ref " (fun k -> fst k)
(** This function performs the identifier (idref) resolution,
i.e., when an ident is not explicitely prefixed by a module
name, we decide here to which module it belongs.
The [provide_flag] indicates whether that function was called
from a provide part or not.
*)
let solve_x_idref
x_check_interface x_check find_x x_label to_x_key this symbols
provide_flag currpack idr sargs lxm =
let s = Ident.name_of_idref idr in
match Ident.pack_of_idref idr with
| Some p -> x_check_interface this (to_x_key p s) lxm
| None ->
(* no pack name: it must be in the symbols table *)
try
match (find_x symbols s lxm) with
| SymbolTab.Local x_info ->
if provide_flag
then x_check_interface this (to_x_key currpack s) lxm
else x_check this (to_x_key currpack s) lxm
| SymbolTab.Imported(fid,params) ->
let (pi,si) = (Ident.pack_of_long fid, Ident.of_long fid) in
assert(params=[]); (* todo *)
x_check_interface this (to_x_key pi si) lxm
with Not_found ->
(raise (Compile_error(lxm,"unbounded " ^ x_label ^ " ident")))
(* And now we can start the big mutually recursive definition... *)
(** Tabulated version of [type_check_do]. *)
let rec (type_check : t -> Ident.long -> Lxm.t -> Eff.type_) =
fun this ->
x_check this.types SymbolTab.find_type type_check_do lookup_type_eff
Ident.pack_of_long Ident.of_long this
(** Tabulated version of [const_check_do]. *)
and (const_check : t -> Ident.long -> Lxm.t -> Eff.const) =
fun this ->
x_check this.consts SymbolTab.find_const const_check_do lookup_const_eff
Ident.pack_of_long Ident.of_long this
(** Tabulated version of [type_check_interface_do]. *)
and (type_check_interface: t -> Ident.long -> Lxm.t -> Eff.type_) =
fun this ->
x_check_interface
this.prov_types SymbolTab.find_type type_check type_check_interface_do
lookup_type_eff Ident.pack_of_long Ident.of_long this
(** Tabulated version of [const_check_interface_do]. *)
and (const_check_interface: t -> Ident.long -> Lxm.t -> Eff.const) =
fun this ->
x_check_interface
this.prov_consts SymbolTab.find_const const_check const_check_interface_do
lookup_const_eff Ident.pack_of_long Ident.of_long this
(** solving type and constant references *)
and (solve_type_idref : t -> SymbolTab.t -> bool -> Ident.pack_name ->
Ident.idref -> Lxm.t -> Eff.type_) =
fun this symbols provide_flag currpack idr lxm ->
solve_x_idref
type_check_interface type_check SymbolTab.find_type "type"
(fun p id -> Ident.make_long p id)
this symbols provide_flag currpack idr [] lxm
and (solve_const_idref : t -> SymbolTab.t -> bool -> Ident.pack_name -> Ident.idref -> Lxm.t -> Eff.const) =
fun this symbols provide_flag currpack idr lxm ->
solve_x_idref
const_check_interface const_check SymbolTab.find_const "const"
(fun p id -> Ident.make_long p id)
this symbols provide_flag currpack idr [] lxm
(* now the real work! *)
and (type_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
Ident.pack_name -> SyntaxTreeCore.type_info srcflagged ->
Eff.type_) =
fun this type_name lxm prov_symbols pack_name type_def ->
(* We type check the interface and the body.
For non-abstract types, we also check that both effective types are
the same. *)
let body_type_eff = type_check this type_name lxm in
let prov_type_eff =
type_check_do this type_name lxm prov_symbols true pack_name type_def
in
if Eff.type_are_compatible prov_type_eff body_type_eff then
prov_type_eff
else
raise(Compile_error (
type_def.src,
("provided type \n\t" ^
(LicDump.string_of_type_eff prov_type_eff) ^
"\n is not compatible with its implementation \n\t" ^
(LicDump.string_of_type_eff body_type_eff))))
and (const_check_interface_do: t -> Ident.long -> Lxm.t -> SymbolTab.t ->
Ident.pack_name -> SyntaxTreeCore.const_info srcflagged ->
Eff.const) =
fun this cn lxm prov_symbols p const_def ->
let prov_const_eff = const_check_do this cn lxm prov_symbols true p const_def in
let body_const_eff = const_check this cn lxm in
match prov_const_eff with
| Eff.Extern_const_eff (id, teff_prov, v_opt) ->
let teff_body = Eff.type_of_const body_const_eff in
if (id <> cn) then
assert false
else if v_opt <> None && v_opt <> Some(body_const_eff) then
raise(Compile_error (const_def.src, " constant values mismatch"))
else if Eff.type_are_compatible teff_prov teff_body then
prov_const_eff
else
raise(Compile_error (
const_def.src,
("provided constant type \n***\t" ^
(LicDump.string_of_type_eff teff_prov) ^
" is not compatible with its implementation \n***\t" ^
(LicDump.string_of_type_eff teff_body) ^ "")
))
| Eff.Enum_const_eff (_, _)
| Eff.Bool_const_eff _
| Eff.Int_const_eff _
| Eff.Real_const_eff _
| Eff.Struct_const_eff (_,_)
| Eff.Array_const_eff (_,_)
->
if prov_const_eff = body_const_eff then
body_const_eff
else
raise(Compile_error (
const_def.src,
"\n*** provided constant does not match with its definition."))
and (type_check_do: t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool -> Ident.pack_name -> SyntaxTreeCore.type_info srcflagged ->
Eff.type_) =
fun this type_name lxm symbols provide_flag pack_name type_def ->
try (
(* Solveur d'idref pour les appels eval_type/eval_const *)
let id_solver = {
id2var = (fun idref lxm -> assert false (* should not occur *));
id2const = solve_const_idref this symbols provide_flag pack_name;
id2type = solve_type_idref this symbols provide_flag pack_name;
id2node = solve_node_idref this symbols provide_flag pack_name;
symbols = symbols;
}
in
let type_eff =
match type_def.it with
| ArrayType _ -> finish_me " array handling "; assert false
| ExternalType s -> External_type_eff (Ident.make_long pack_name s)
| AliasedType (s, texp) -> GetEff.typ id_solver texp
| EnumType (s, clst) -> (
let n = Ident.make_long pack_name s in
let add_pack_name x = Ident.make_long pack_name x.it in
Enum_type_eff (n, List.map add_pack_name clst)
)
| StructType sti -> (
let make_field (fname : Ident.t) =
let field_def = Hashtbl.find sti.st_ftable fname in
let teff = GetEff.typ id_solver field_def.it.fd_type in
match field_def.it.fd_value with
| None -> (fname, (teff, None))
| Some vexp -> (
let veff = EvalConst.f id_solver vexp in
match veff with
| [v] -> (
let tv = Eff.type_of_const v in
if (tv = teff) then (fname, (teff, Some v)) else
raise
(Compile_error(field_def.src, Printf.sprintf
" this field is declared as '%s' but evaluated as '%s'"
(LicDump.string_of_type_eff teff)
(LicDump.string_of_type_eff tv)))
)
| [] -> assert false (* should not occur *)
| _::_ ->
raise (Compile_error(field_def.src,
"bad field value: tuple not allowed"))
)
in
let n = Ident.make_long pack_name sti.st_name in
let eff_fields = List.map make_field sti.st_flist in
Struct_type_eff (n, eff_fields)
)
in
if not provide_flag then
output_string !Global.oc (LicDump.type_decl type_name type_eff);
type_eff
)
with
(* capte et complete/stoppe les recursions *)
Recursion_error (root, stack) ->
if (root = type_name) then recursion_error type_def.src stack else
raise ( Recursion_error (root, ("type ref "^(Lxm.details lxm))::stack))
and (const_check_do : t -> Ident.long -> Lxm.t -> SymbolTab.t -> bool ->
Ident.pack_name -> SyntaxTreeCore.const_info srcflagged ->
Eff.const) =
fun this cn lxm symbols provide_flag currpack const_def ->
(* [cn] and [lxm] are used for recursion errors.
[symbols] is the current symbol table.
*) try (
(* Solveur d'idref pour les les appels eval_type/eval_const *)
let id_solver = {
id2var = (fun idref lxm -> assert false (* should not occur *));
id2const = solve_const_idref this symbols provide_flag currpack;
id2type = solve_type_idref this symbols provide_flag currpack;
id2node = solve_node_idref this symbols provide_flag currpack;
symbols = symbols;
}
in
let const_eff =
match const_def.it with
| ExternalConst (id, texp, val_opt) ->
Extern_const_eff ((Ident.make_long currpack id),
GetEff.typ id_solver texp,
match val_opt with
| None -> None
| Some c -> (
match EvalConst.f id_solver c with
| [ceff] -> Some ceff
| _ -> assert false
)
)
| EnumConst (id, texp) ->
Enum_const_eff ((Ident.make_long currpack id), GetEff.typ id_solver texp)
| DefinedConst (id, texp_opt, vexp ) -> (
match (EvalConst.f id_solver vexp) with
| [ceff] -> (
match texp_opt with
| None -> ceff
| Some texp -> (
let tdecl = GetEff.typ id_solver texp in
let teff = Eff.type_of_const ceff in
if (tdecl = teff ) then ceff else
raise
(Compile_error (const_def.src, Printf.sprintf
" this constant is declared as '%s' but evaluated as '%s'"
(LicDump.string_of_type_eff tdecl)
(LicDump.string_of_type_eff teff)
)))
)
| [] -> assert false (* should not occur *)
| _::_ -> raise (Compile_error(const_def.src,
"bad constant value: tuple not allowed"))
)
in
if not provide_flag then
output_string !Global.oc (LicDump.const_decl cn const_eff);
const_eff
) with Recursion_error (root, stack) -> (
(* capte et complete/stoppe les recursions *)
if (root = cn) then recursion_error const_def.src stack else
(* on complete la stack *)
raise (Recursion_error (root, ("const ref "^(Lxm.details lxm))::stack))
)
(******************************************************************************)
and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
SymbolTab.t -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
Eff.node_exp) =
fun this nk lxm symbols pn node_def ->
let body_node_exp_eff = node_check this nk lxm in
let prov_node_exp_eff = node_check_do this nk lxm symbols true pn node_def in
(** [type_eff_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
if t1 = t2 or t1 is abstract and and t2.
*)
let msg_prefix =
("provided node for " ^ (Ident.string_of_long (fst nk)) ^ " is not compatible with its implementation: ")
in
let str_of_var = LicDump.type_string_of_var_info_eff in
let type_is_not_comp v1 v2 = not (Eff.var_are_compatible v1 v2) in
if
prov_node_exp_eff.node_key_eff <> body_node_exp_eff.node_key_eff
then
raise(Compile_error (node_def.src, msg_prefix ^ " ??? "))
else if
(List.exists2 type_is_not_comp
prov_node_exp_eff.inlist_eff body_node_exp_eff.inlist_eff)
then
let msg = msg_prefix ^ "bad input profile. \n*** " ^
(String.concat "*" (List.map str_of_var prov_node_exp_eff.inlist_eff)) ^
" <> " ^
(String.concat "*" (List.map str_of_var body_node_exp_eff.inlist_eff))
in
raise(Compile_error (node_def.src, msg))
else if
(List.exists2 type_is_not_comp
prov_node_exp_eff.outlist_eff body_node_exp_eff.outlist_eff)
then
let msg = msg_prefix ^ "bad output profile. \n*** " ^
(String.concat "*" (List.map str_of_var prov_node_exp_eff.outlist_eff)) ^
" <> " ^
(String.concat "*" (List.map str_of_var body_node_exp_eff.outlist_eff))
in
raise(Compile_error (node_def.src, msg))
else if
prov_node_exp_eff.has_mem_eff <> body_node_exp_eff.has_mem_eff
then
raise(Compile_error (node_def.src, msg_prefix ^ " node or function?"))
else if
prov_node_exp_eff.is_safe_eff <> body_node_exp_eff.is_safe_eff
then
raise(Compile_error (node_def.src, msg_prefix ^ "safe or unsafe?"))
else if
match prov_node_exp_eff.def_eff, body_node_exp_eff.def_eff with
| (AbstractEff,_) -> false
| (_,_) -> prov_node_exp_eff.def_eff <> body_node_exp_eff.def_eff
then
raise(Compile_error (node_def.src, msg_prefix ^ "abstract or not?"))
else
prov_node_exp_eff
and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
bool -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
Eff.node_exp) =
fun this nk lxm symbols provide_flag pack_name node_def ->
let lxm = node_def.src in
let local_env = make_local_env nk in
let node_id_solver = {
(* a [node_id_solver] is a [id_solver] where we begin to look
into the local environement before looking at the global
one. *)
id2var = (* var can only be local to the node *)
(fun id lxm ->
try lookup_var local_env (Ident.of_idref id) lxm
with Not_found ->
raise (Compile_error(
lxm,
"\n*** '"^(Ident.string_of_idref id)^
"': Unknown variable.\n*** Current variables are: " ^
(Hashtbl.fold
(fun id vi_eff acc ->
acc ^ (Format.sprintf
"\n\t%s" (LicDump.string_of_var_info_eff vi_eff))
)
local_env.lenv_vars ""
))));
id2const =
(fun id lxm ->
try lookup_const local_env id lxm
with Not_found ->
solve_const_idref this symbols provide_flag pack_name id lxm);
id2type =
(fun id lxm ->
try lookup_type local_env id lxm
with Not_found ->
solve_type_idref this symbols provide_flag pack_name id lxm);
id2node =
(fun id sargs lxm ->
try lookup_node local_env id sargs lxm
with Not_found ->
solve_node_idref this symbols provide_flag pack_name id sargs lxm);
symbols = symbols;
}
in
let find_var_info lxm vars id =
try Hashtbl.find vars.vartable id
with Not_found ->
raise (Compile_error
(lxm,"\n*** Unknown ident: " ^ (Ident.to_string id)))
in
let make_node_eff node_def_eff =
(* building not aliased nodes *)
match node_def.it.vars with
| None -> assert false (* a node with a body should have a profile *)
| Some vars ->
let type_args id =
let vi = find_var_info lxm vars id in
let t_eff = GetEff.typ node_id_solver vi.it.var_type in
let c_eff = GetEff.clock node_id_solver vi.it in
let vi_eff = {
var_name_eff = vi.it.var_name;
var_nature_eff = vi.it.var_nature;
var_number_eff = vi.it.var_number;
var_type_eff = t_eff;
var_clock_eff = c_eff;
}
in
Hashtbl.add local_env.lenv_types id t_eff;
Hashtbl.add local_env.lenv_vars id vi_eff;
vi_eff
in
let (sort_vars : Ident.t list -> Ident.t list) =
fun l ->
(* I cannot use List.sort as I only have a partial order on vars
-> hence I perform a topological sort *)
let rec depends_on v1 v2 =
match (find_var_info lxm vars v1).it.var_clock with
| Base -> false
| NamedClock({it=(_,v1clk)}) -> v1clk = v2 || depends_on v1clk v2
in
let rec aux acc l = match l with
| [] -> acc
| v::tail -> (
match (find_var_info lxm vars v).it.var_clock with
| Base ->
if List.mem v acc then
aux acc tail
else
aux (v::acc) tail
| NamedClock( { it=(_,v2) ; src=lxm }) ->
if List.mem v2 acc then
aux (v::acc) tail
else if
depends_on v2 v then
raise (
Compile_error (
lxm,
"\n*** Clock dependency loop: " ^
(Ident.to_string v) ^ " depends on " ^
(Ident.to_string v2) ^ ", which depends on " ^
(Ident.to_string v))
)
else
let l1,l2 = List.partition (fun v -> v=v2) l in
if l1 = [] then
(* v depends on a clock not in l *)
aux (v::acc) tail
else
aux acc (v2::l2)
)
in
List.rev(aux [] l)
in
let vars_in_sorted = sort_vars vars.inlist
and vars_out_sorted = sort_vars vars.outlist in
let inlist = List.map type_args vars_in_sorted
and outlist = List.map type_args vars_out_sorted
and loclist =
match vars.loclist with
| None -> None
| Some loclist ->
let vars_loc_sorted = sort_vars loclist in
Some (List.map type_args vars_loc_sorted)
in
let unsort l_id l_vi =
let tab = List.map (fun vi -> vi.var_name_eff, vi) l_vi in
try List.map (fun id -> List.assoc id tab) l_id
with Not_found -> assert false
in
let inlist2 = unsort vars.inlist inlist
and outlist2 = unsort vars.outlist outlist in
{
node_key_eff = nk;
inlist_eff = inlist2;
outlist_eff = outlist2;
loclist_eff = loclist;
def_eff = node_def_eff ();
has_mem_eff = node_def.it.has_mem;
is_safe_eff = node_def.it.is_safe;
lxm = lxm;
}
in
let (make_alias_node : Eff.node_exp -> Eff.node_exp) =
fun aliased_node ->
(* builds a node that calls the aliased node. It looks like:
node alias_node( ins ) returns ( outs );
let
outs = aliased_node(ins);
tel
*)
let (outs:Eff.left list) =
List.map (fun vi -> LeftVarEff (vi, lxm)) aliased_node.outlist_eff
and (aliased_node_call : Eff.val_exp) =
CallByPosEff(
(Lxm.flagit (Eff.CALL(Lxm.flagit aliased_node lxm)) lxm,
OperEff
(List.map
(fun vi -> (* build operands*)
CallByPosEff(
Lxm.flagit (Eff.IDENT
(Ident.to_idref vi.var_name_eff)) lxm, OperEff [])
)
aliased_node.inlist_eff))) in
{
aliased_node with
node_key_eff = nk;
loclist_eff = None;
def_eff = BodyEff(
{ asserts_eff = [];
eqs_eff = [Lxm.flagit (outs, aliased_node_call) lxm]
});
}
in
(* let's go *)
let res =
match node_def.it.def with
| Abstract -> make_node_eff (fun () -> AbstractEff)
| Extern -> make_node_eff (fun () -> ExternEff)
| Body nb ->
make_node_eff (
(fun () -> (* trick to force to delay this evaluation
after the local_env.lenv_vars has been
filled
*)
let eq_eff = List.map (GetEff.eq node_id_solver) nb.eqs in
BodyEff {
asserts_eff =
List.map (GetEff.assertion node_id_solver) nb.asserts;
eqs_eff = eq_eff;
}
)
)
| Alias({it= alias;src=lxm}) -> (
let aliased_node =
match alias with
| Predef_n((Predef.NOR_n|Predef.DIESE_n), sargs) ->
raise (Compile_error (lxm, "Can not alias 'nor' nor '#', sorry"))
(* | Predef_n( *)
(* (Predef.NEQ_n | Predef.EQ_n | Predef.LT_n | Predef.LTE_n *)
(* | Predef.GT_n | Predef.GTE_n | Predef.IF_n), _sargs *)
(* ) -> *)
(* raise (Compile_error ( *)
(* lxm, "can not alias polymorphic operators, sorry")) *)
(* | Predef_n( *)
(* ( Predef.UMINUS_n | Predef.MINUS_n | Predef.PLUS_n *)
(* | Predef.TIMES_n | Predef.SLASH_n), _sargs *)
(* ) -> *)
(* raise (Compile_error ( *)
(* lxm, "can not alias overloaded operators, sorry")) *)
| Predef_n(predef_op, sargs) ->
let sargs_eff =
GetEff.translate_predef_static_args node_id_solver sargs lxm
in
PredefEvalType.make_node_exp_eff
(Some node_def.it.has_mem) predef_op lxm sargs_eff
| CALL_n(node_alias) ->
GetEff.node node_id_solver node_alias
| (MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _
|IDENT_n _|ARRAY_n|HAT_n|CONCAT_n|WITH_n(_)|TUPLE_n|WHEN_n _
|CURRENT_n|FBY_n|ARROW_n|PRE_n)
->
raise (Compile_error (lxm, "can not alias this operator, sorry"))
(* does it make sense to alias when, pre, etc? *)
in
let alias_node = make_alias_node aliased_node in
(* Check that the declared profile (if any) matches with the alias *)
match node_def.it.vars with
| None -> alias_node
| Some vars -> let vi_il, vi_ol =
List.map (fun id -> find_var_info lxm vars id) vars.inlist,
List.map (fun id -> find_var_info lxm vars id) vars.outlist
in
let aux vi = GetEff.typ node_id_solver vi.it.var_type
in
let (il,ol) = Eff.profile_of_node_exp alias_node in
let (il_exp, ol_exp) = List.map aux vi_il, List.map aux vi_ol in
match UnifyType.f il_exp il with
| UnifyType.Ko msg -> raise(Compile_error(lxm, msg))
| _ ->
match UnifyType.f ol_exp ol with
| UnifyType.Ko msg -> raise(Compile_error (lxm, msg))
| _ ->
alias_node
)
in
let res = if !Global.one_op_per_equation then Split.node local_env res else res in
let res =
if !Global.inline_iterator
then Inline.iterators local_env node_id_solver res
else res
in
if not provide_flag then
output_string !Global.oc (LicDump.node_of_node_exp_eff res);
UniqueOutput.check res node_def.src;
res
(** builds a [node_key] and calls [node_check] *)
and (solve_node_idref : t -> SymbolTab.t -> bool -> Ident.pack_name -> Ident.idref ->
Eff.static_arg list -> Lxm.t -> Eff.node_exp) =
fun this symbols provide_flag currpack idr sargs lxm ->
solve_x_idref
node_check_interface node_check SymbolTab.find_node "node"
(fun p id ->
(* builds a [node_key] from a [pack_name] and a [node] id,
and a Eff.static_arg list *)
let long = Ident.make_long p id in
let node_key = long, sargs in
node_key
)
this symbols provide_flag currpack idr sargs lxm
and (node_check: t -> Eff.node_key -> Lxm.t -> Eff.node_exp) =
fun this nk ->
x_check this.nodes SymbolTab.find_node node_check_do lookup_node_exp_eff
(fun nk -> Ident.pack_of_long (fst nk))
(fun nk -> Ident.of_long (fst nk))
this nk
and (node_check_interface:
t -> Eff.node_key -> Lxm.t -> Eff.node_exp) =
fun this nk ->
x_check_interface this.prov_nodes SymbolTab.find_node node_check
node_check_interface_do lookup_node_exp_eff
(fun nk -> Ident.pack_of_long (fst nk))
(fun nk -> Ident.of_long (fst nk)) this nk
(*-------------------------------------------------------------------------
compile all items
---------------------------------------------------------------------------*)
let compile_all_item this label x_check_interface string_of_x_key
string_of_x_eff to_key id item_def =
match item_def with
| SymbolTab.Local _item_def -> ignore
(x_check_interface this (to_key id) (Lxm.dummy "compile all items"))
(* Printf.printf "\t\t%s %s = %s\n" *)
(* label (string_of_x_key (to_key id)) (string_of_x_eff x_eff) *)
| SymbolTab.Imported(item_def,_) -> ()
(* Printf.printf "\t\t%s %s = %s (imported)\n" *)
(* label (string_of_x_key (to_key id)) (Ident.string_of_long item_def) *)
let compile_all_types pack_name this =
compile_all_item this "type" type_check_interface Ident.string_of_long
LicDump.string_of_type_eff (fun id -> Ident.make_long pack_name id)
let compile_all_constants pack_name this =
compile_all_item this "const" const_check_interface Ident.string_of_long
LicDump.string_of_const_eff (fun id -> Ident.make_long pack_name id)
let (get_static_params : (node_info Lxm.srcflagged) SymbolTab.elt ->
static_param srcflagged list) =
fun node_info_flagged ->
match node_info_flagged with
| SymbolTab.Local nif -> nif.it.static_params
| SymbolTab.Imported(id,sparams) -> sparams
let compile_all_nodes pack_name this id ni_f =
let sp = get_static_params ni_f in
if sp <> [] then () (* we need static arg to compile such kind of things *)
else
compile_all_item this "node" node_check_interface
(LicDump.string_of_node_key_rec)
Eff.profile_of_node_exp
(fun id -> (Ident.make_long pack_name id, [])) id ni_f
let (compile_all :t -> unit) =
fun this ->
let testpack pack_name = (
Verbose.printf ~level:3 " * package %s\n" (Ident.pack_name_to_string pack_name);
let prov_symbols =
match SyntaxTab.pack_prov_env this.src_tab pack_name (Lxm.dummy "") with
| Some tab -> tab
| None -> SyntaxTab.pack_body_env this.src_tab pack_name
in
Verbose.print_string ~level:3 "\tExported types:\n";
SymbolTab.iter_types prov_symbols (compile_all_types pack_name this);
flush stdout;
Verbose.print_string ~level:3 "\tExported constants:\n";
SymbolTab.iter_consts prov_symbols (compile_all_constants pack_name this);
flush stdout;
Verbose.print_string ~level:3 "\tExported nodes:\n";
SymbolTab.iter_nodes prov_symbols (compile_all_nodes pack_name this);
flush stdout
)
in
let plist = SyntaxTab.pack_list this.src_tab in
Verbose.print_string ~level:3 "*** Dump the exported items of the packages.\n";
try
List.iter testpack plist
with
Recursion_error (root, stack) ->
recursion_error (Lxm.dummy "") stack