heptagon/compiler/global/static.ml

219 lines
7.9 KiB
OCaml
Raw Normal View History

(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(** This module defines static expressions, used in params and for constants.
const n: int = 3;
var x : int^n; var y : int^(n + 2);
x[n - 1], x[1 + 3],... *)
open Names
2010-06-15 10:49:03 +02:00
open Format
open Types
2010-07-08 14:56:49 +02:00
open Signature
open Modules
2011-03-17 17:10:36 +01:00
open Location
2010-06-15 10:49:03 +02:00
2010-06-15 10:49:03 +02:00
exception Not_static
2011-03-17 17:10:36 +01:00
(** Some evaluations are not possible *)
type eval_error = Division_by_zero
exception Evaluation_failed of eval_error * location
(** Some unknown operators could be used preventing the evaluation *)
type partial_eval_cause = Unknown_op of fun_name | Unknown_param of qualname
exception Partial_evaluation of partial_eval_cause * location
let message exn =
begin match exn with
| Evaluation_failed (e,loc) ->
(match e with
| Division_by_zero ->
eprintf "%aForbidden division by 0.@."
print_location loc
)
| Partial_evaluation (e,loc) ->
(match e with
| Unknown_op op ->
eprintf "%aUnknown operator %a.@."
Location.print_location loc
Global_printer.print_qualname op
| Unknown_param q ->
eprintf "%aUninstanciated param %a.@."
Location.print_location loc
Global_printer.print_qualname q
)
| _ -> raise exn
end;
raise Errors.Error
(** When not [partial],
2011-05-23 09:24:57 +02:00
@raise Partial_evaluation when the application of the operator can't be evaluated.
2011-03-17 17:10:36 +01:00
Otherwise keep as it is unknown operators. *)
let apply_op partial loc op se_list =
let has_var_desc acc se =
let has_var _ _ sed = match sed with
| Svar _ -> sed,true
| _ -> raise Errors.Fallback
in
let se, acc =
Global_mapfold.static_exp_it
{Global_mapfold.defaults with Global_mapfold.static_exp_desc = has_var}
acc se
in
se.se_desc, acc
in
let sed_l, has_var = Misc.mapfold has_var_desc false se_list in
if (op.qual = Pervasives) && not has_var
then (
match op.name, sed_l with
| "+", [Sint n1; Sint n2] -> Sint (n1 + n2)
| "-", [Sint n1; Sint n2] -> Sint (n1 - n2)
| "*", [Sint n1; Sint n2] -> Sint (n1 * n2)
| "/", [Sint n1; Sint n2] ->
if n2 = 0 then raise (Evaluation_failed (Division_by_zero, loc));
Sint (n1 / n2)
| "=", [Sint n1; Sint n2] -> Sbool (n1 = n2)
| "<=", [Sint n1; Sint n2] -> Sbool (n1 <= n2)
| ">=", [Sint n1; Sint n2] -> Sbool (n1 >= n2)
| "<", [Sint n1; Sint n2] -> Sbool (n1 < n2)
| ">", [Sint n1; Sint n2] -> Sbool (n1 > n2)
| "&", [Sbool b1; Sbool b2] -> Sbool (b1 && b2)
| "or", [Sbool b1; Sbool b2] -> Sbool (b1 || b2)
| "not", [Sbool b] -> Sbool (not b)
| "~-", [Sint n] -> Sint (-n)
| f,_ -> Misc.internal_error ("Static evaluation failed of the pervasive operator "^f)
)
else
if partial
then Sop(op, se_list) (* partial evaluation *)
else raise (Partial_evaluation (Unknown_op op, loc))
2010-08-24 17:24:22 +02:00
2011-03-17 17:10:36 +01:00
(** When not [partial],
2011-05-23 09:24:57 +02:00
@raise Partial_evaluation when a static var cannot be evaluated,
a local static parameter for example.
2011-03-17 17:10:36 +01:00
Otherwise evaluate in a best effort manner. *)
let rec eval_core partial env se = match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sstring _ | Sconstructor _ | Sfield _ -> se
2011-03-17 17:10:36 +01:00
| Svar ln ->
(try (* first try to find in global const env *)
let cd = find_const ln in
eval_core partial env cd.c_value
with Not_found -> (* then try to find in local env *)
2011-03-21 14:30:19 +01:00
(try
let se = QualEnv.find ln env in
(match se.se_desc with
| Svar ln' when ln'=ln -> (* prevent basic infinite loop *)
if partial then se else raise Not_found
| _ -> eval_core partial env se
)
with Not_found -> (* Could not evaluate the var *)
2011-03-17 17:10:36 +01:00
if partial then se
else raise (Partial_evaluation (Unknown_param ln, se.se_loc))
)
)
2010-08-24 17:24:22 +02:00
| Sop (op, se_list) ->
2011-03-17 17:10:36 +01:00
let se_list = List.map (eval_core partial env) se_list in
let se_desc = apply_op partial se.se_loc op se_list in
{ se with se_desc = se_desc }
2010-08-24 17:24:22 +02:00
| Sarray se_list ->
2011-03-17 17:10:36 +01:00
{ se with se_desc = Sarray (List.map (eval_core partial env) se_list) }
2010-08-24 17:24:22 +02:00
| Sarray_power (se, n) ->
2011-03-17 17:10:36 +01:00
{ se with se_desc = Sarray_power (eval_core partial env se, eval_core partial env n) }
2010-08-24 17:24:22 +02:00
| Stuple se_list ->
2011-03-17 17:10:36 +01:00
{ se with se_desc = Stuple (List.map (eval_core partial env) se_list) }
2010-08-24 17:24:22 +02:00
| Srecord f_se_list ->
{ se with se_desc = Srecord
2011-03-17 17:10:36 +01:00
(List.map (fun (f,se) -> f, eval_core partial env se) f_se_list) }
2010-08-24 17:24:22 +02:00
(** [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.*)
2011-03-17 17:10:36 +01:00
let simplify env se =
try eval_core true env se
with exn -> message exn
2010-08-24 17:24:22 +02:00
(** [eval env e] does the same as [simplify]
but if it returns, there are no variables nor op left.
2011-03-17 17:10:36 +01:00
@raise [Errors.Error] when it cannot fully evaluate. *)
let eval env se =
try eval_core false env se
with exn -> message exn
2010-06-30 17:20:56 +02:00
(** [int_of_static_exp env e] returns the value of the expression
2011-03-17 17:10:36 +01:00
[e] in the environment [env], mapping vars to integers.
@raise [Errors.Error] if it cannot be computed.*)
let int_of_static_exp env se = match (eval env se).se_desc with
2011-03-17 10:02:35 +01:00
| Sint i -> i
2011-05-23 09:24:57 +02:00
| _ -> Misc.internal_error "static int_of_static_exp"
2010-06-15 10:49:03 +02:00
(** [is_true env constr] returns whether the constraint is satisfied
in the environment (or None if this can be decided)
and a simplified constraint. *)
let is_true env c =
let c = simplify env c in
match c.se_desc with
| Sbool b -> Some b, c
| _ -> None, c
exception Solve_failed of constrnt
2010-06-15 10:49:03 +02:00
(** [solve env constr_list solves a list of constraints. It
removes equations that can be decided and simplify others.
2010-06-15 10:49:03 +02:00
If one equation cannot be satisfied, it raises Solve_failed. ]*)
let rec solve const_env =
function
| [] -> []
| c :: l ->
let l = solve const_env l in
let (res, c) = is_true const_env c in
(match res with
| None -> c :: l
| Some v -> if not v then raise (Solve_failed c) else l)
(*
2010-06-15 10:49:03 +02:00
(** Substitutes variables in the size exp with their value
in the map (mapping vars to size exps). *)
2010-07-07 12:15:02 +02:00
let rec static_exp_subst m se =
2010-07-08 14:56:49 +02:00
match se.se_desc with
| Svar qn -> (try QualEnv.find qn m with | Not_found -> se)
2010-07-08 14:56:49 +02:00
| Sop (op, se_list) ->
{ se with se_desc = Sop (op, List.map (static_exp_subst m) se_list) }
| Sarray_power (se, n) ->
{ se with se_desc = Sarray_power (static_exp_subst m se,
static_exp_subst m n) }
| Sarray se_list ->
{ se with se_desc = Sarray (List.map (static_exp_subst m) se_list) }
| Stuple se_list ->
{ se with se_desc = Stuple (List.map (static_exp_subst m) se_list) }
2010-07-07 12:15:02 +02:00
| Srecord f_se_list ->
2010-07-08 14:56:49 +02:00
{ se with se_desc =
Srecord (List.map
(fun (f,se) -> f, static_exp_subst m se) f_se_list) }
| _ -> se
2010-06-15 10:49:03 +02:00
(** Substitutes variables in the constraint list with their value
in the map (mapping vars to size exps). *)
let instanciate_constr m constr =
let replace_one m = function
2010-07-01 19:32:54 +02:00
| Cequal (e1, e2) -> Cequal (static_exp_subst m e1, static_exp_subst m e2)
| Clequal (e1, e2) -> Clequal (static_exp_subst m e1, static_exp_subst m e2)
| Cfalse -> Cfalse in
List.map (replace_one m) constr
*)