Callgraph_mapfold polished.

compiler/global/static.ml

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

compiler/global/types.ml

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

compiler/minils/transformations/callgraph_mapfold.ml

@@ -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 ->
+      | Epartial_instanciation se ->
-          Format.eprintf "%aUnbound static var '%s'\n"
+          Format.eprintf "%aUnable to fully instanciate the static exp '%a'@."
-            print_location loc
+            print_location se.se_loc
-            n
+            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