heptagon/compiler/global/static.ml
Léonard Gérard a54e570d0f Hept Scoping should be ok and documented,
Hept Parsing too,
all the reset to review carefully,
Typing to cut from all the scoping.
2010-09-09 19:48:20 +02:00

170 lines
6.4 KiB
OCaml

(**************************************************************************)
(* *)
(* 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
open Format
open Types
open Signature
open Modules
(* unsatisfiable constraint *)
exception Instanciation_failed
exception Partial_instanciation of static_exp
exception Not_static
let partial_apply_op op se_list =
match se_list with
| [{ se_desc = Sint n1 }; { se_desc = Sint n2 }] ->
(match op with
| { qual = "Pervasives"; name = "+" } ->
Sint (n1 + n2)
| { qual = "Pervasives"; name = "-" } ->
Sint (n1 - n2)
| { qual = "Pervasives"; name = "*" } ->
Sint (n1 * n2)
| { qual = "Pervasives"; name = "/" } ->
let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in
Sint n
| { qual = "Pervasives"; name = "=" } ->
Sbool (n1 = n2)
| _ -> assert false (*TODO: add missing operators*)
)
| [{ se_desc = Sint n }] ->
(match op with
| { qual = "Pervasives"; name = "~-" } -> Sint (-n)
| _ -> assert false (*TODO: add missing operators*)
)
| _ -> 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 cd = find_const ln in
eval env cd.c_value
with Not_found -> (* then try to find in local env *)
eval env (QualEnv.find ln env))
| 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
Instanciation_failed if it cannot be computed (if a var has no value).*)
let int_of_static_exp env se =
match (simplify env se).se_desc with
| Sint i -> i
| _ ->
(Format.eprintf "Internal compiler error, \
[eval_int] received the static_exp %a.@."
Global_printer.print_static_exp se;
assert false)
(** [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 =
function
| Cequal (e1, e2) when e1 = e2 ->
Some true, Cequal (simplify env e1, simplify env e2)
| Cequal (e1, e2) ->
let e1 = simplify env e1 in
let e2 = simplify env e2 in
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 = n2), Cequal (e1, e2)
| (_, _) -> None, Cequal (e1, e2))
| Clequal (e1, e2) ->
let e1 = simplify env e1 in
let e2 = simplify env e2 in
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 <= n2), Clequal (e1, e2)
| _, _ -> None, Clequal (e1, e2))
| Cfalse -> None, Cfalse
exception Solve_failed of size_constraint
(** [solve env constr_list solves a list of constraints. It
removes equations that can be decided and simplify others.
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)
(** Substitutes variables in the size exp with their value
in the map (mapping vars to size exps). *)
let rec static_exp_subst m se =
match se.se_desc with
| Svar qn -> (try QualEnv.find qn m with | Not_found -> se)
| 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) }
| Srecord f_se_list ->
{ se with se_desc =
Srecord (List.map
(fun (f,se) -> f, static_exp_subst m se) f_se_list) }
| _ -> se
(** 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
| 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