Callgraph_mapfold polished.

This commit is contained in:
Léonard Gérard 2010-08-24 17:24:22 +02:00
parent 9df4f625a2
commit aef39b8036
3 changed files with 56 additions and 37 deletions

View file

@ -21,6 +21,7 @@ open Modules
(* unsatisfiable constraint *)
exception Instanciation_failed
exception Partial_instanciation of static_exp
exception Not_static
@ -30,34 +31,9 @@ let op_from_app_name ln =
| Modname { qual = "Pervasives" } -> ln
| _ -> raise Not_static
(** [simplify env e] returns e simplified with the
variables values taken from env (mapping vars to integers).
Variables are replaced with their values and every operator
that can be computed is replaced with the value of the result. *)
let rec simplify env se = match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sconstructor _ -> se
| Svar ln -> (
try
let { info = cd } = find_const ln in
simplify env cd.c_value
with Not_found -> (
match ln with
| Name n -> (try simplify env (NamesEnv.find n env) with | _ -> se)
| Modname _ -> se ) )
| Sop (op, se_list) ->
let se_list = List.map (simplify env) se_list in
{ se with se_desc = apply_op op se_list }
| Sarray se_list ->
{ se with se_desc = Sarray (List.map (simplify env) se_list) }
| Sarray_power (se, n) ->
{ se with se_desc = Sarray_power (simplify env se, simplify env n) }
| Stuple se_list ->
{ se with se_desc = Stuple (List.map (simplify env) se_list) }
| Srecord f_se_list ->
{ se with se_desc = Srecord
(List.map (fun (f,se) -> f, simplify env se) f_se_list) }
and apply_op op se_list =
let partial_apply_op op se_list =
match se_list with
| [{ se_desc = Sint n1 }; { se_desc = Sint n2 }] ->
(match op with
@ -81,6 +57,49 @@ and apply_op op se_list =
)
| _ -> Sop(op, se_list)
let apply_op op se_list =
let se = partial_apply_op op se_list in
match se with
| Sop _ -> raise Not_found
| _ -> se
let eval_core eval apply_op env se = match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sconstructor _ -> se
| Svar ln -> (
try (* first try to find in global const env *)
let { info = cd } = find_const ln in
eval env cd.c_value
with Not_found -> (
match ln with (* then try to find in local env *)
| Name n -> eval env (NamesEnv.find n env)
| Modname _ -> raise Not_found ) )
| Sop (op, se_list) ->
let se_list = List.map (eval env) se_list in
{ se with se_desc = apply_op op se_list }
| Sarray se_list ->
{ se with se_desc = Sarray (List.map (eval env) se_list) }
| Sarray_power (se, n) ->
{ se with se_desc = Sarray_power (eval env se, eval env n) }
| Stuple se_list ->
{ se with se_desc = Stuple (List.map (eval env) se_list) }
| Srecord f_se_list ->
{ se with se_desc = Srecord
(List.map (fun (f,se) -> f, eval env se) f_se_list) }
(** [simplify env e] returns e simplified with the
variables values taken from [env] or from the global env with [find_const].
Every operator that can be computed is.
It can return static_exp with uninstanciated variables.*)
let rec simplify env se =
try eval_core simplify partial_apply_op env se
with _ -> se
(** [eval env e] does the same as [simplify]
but if it returns, there are no variables nor op left.
@raise [Partial_instanciation] when it cannot fully evaluate *)
let rec eval env se =
try eval_core eval apply_op env se
with Not_found -> raise (Partial_instanciation se)
(** [int_of_static_exp env e] returns the value of the expression
[e] in the environment [env], mapping vars to integers. Raises

View file

@ -34,7 +34,7 @@ let prod = function
| [ty] -> ty
| ty_list -> Tprod ty_list
(** DO NOT use this after the typing, since it gives invalid_type *)
(** DO NOT use this after the typing, since it could give invalid_type *)
let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc =
{ se_desc = desc; se_ty = ty; se_loc = loc }

View file

@ -13,7 +13,7 @@ module Error =
struct
type error =
| Enode_unbound of longname
| Evar_unbound of name
| Epartial_instanciation of static_exp
let message loc kind =
begin match kind with
@ -21,10 +21,10 @@ struct
Format.eprintf "%aUnknown node '%s'@."
print_location loc
(fullname ln)
| Evar_unbound n ->
Format.eprintf "%aUnbound static var '%s'\n"
print_location loc
n
| Epartial_instanciation se ->
Format.eprintf "%aUnable to fully instanciate the static exp '%a'@."
print_location se.se_loc
print_static_exp se
end;
raise Misc.Error
end
@ -76,7 +76,10 @@ struct
let nodes_instances = ref LongNameEnv.empty
(** create a params instance *)
let instantiate m se = List.map (simplify m) se
let instantiate m se =
try List.map (eval m) se
with Partial_instanciation se ->
Error.message no_location (Error.Epartial_instanciation se)
(** @return the name of the node corresponding to the instance of
[ln] with the static parameters [params]. *)
@ -137,9 +140,6 @@ struct
| Name n ->
(try NamesEnv.find n m
with Not_found -> (* It should then be in the global env *)
(* TODO should we check it's in the global env ?
I guess it should not be necessary cf typing.
Error.message se.se_loc (Error.Evar_unbound n)) *)
se)
| Modname _ -> se)
| _ -> se in