From 8985e0ffc1b23ef5039383d99bdf46da10a131c1 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Mon, 25 Feb 2019 18:37:39 +0000
Subject: Monomorphisation: fix check for effects in constant propagation The
 old check used the wrong part of the AST.  It would stop when it reached the
 actual effect, anyway, but this should improve performance.

---
 src/monomorphise.ml | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 92a0ae01..784929e1 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -199,10 +199,9 @@ let rec is_value (E_aux (e,(l,annot))) =
 (* TODO: more? *)
   | _ -> false
 
-let is_pure (Effect_opt_aux (e,_)) =
+let is_pure e =
   match e with
-  | Effect_opt_none -> true
-  | Effect_opt_effect (Effect_aux (Effect_set [],_)) -> true
+  | Effect_aux (Effect_set [],_) -> true
   | _ -> false
 
 let rec list_extract f = function
@@ -1507,14 +1506,19 @@ let split_defs all_errors splits defs =
     if not (List.for_all is_value args) then
       None
     else
+      let (tq,typ) = Env.get_val_spec_orig id env in
+      let eff = match typ with
+        | Typ_aux (Typ_fn (_,_,eff),_) -> Some eff
+        | _ -> None
+      in
       let Defs ds = defs in
-      match list_extract (function
+      match eff, list_extract (function
       | (DEF_fundef (FD_aux (FD_function (_,_,eff,((FCL_aux (FCL_Funcl (id',_),_))::_ as fcls)),_)))
-        -> if Id.compare id id' = 0 then Some (eff,fcls) else None
+        -> if Id.compare id id' = 0 then Some fcls else None
       | _ -> None) ds with
-      | None -> None
-      | Some (eff,_) when not (is_pure eff) -> None
-      | Some (_,fcls) ->
+      | None,_ | _,None -> None
+      | Some eff,_ when not (is_pure eff) -> None
+      | Some _,Some fcls ->
          let arg = match args with
            | [] -> E_aux (E_lit (L_aux (L_unit,Generated l)),(Generated l,empty_tannot))
            | [e] -> e
-- 
cgit v1.2.3