diff options
| author | Brian Campbell | 2019-02-25 18:37:39 +0000 |
|---|---|---|
| committer | Brian Campbell | 2019-02-25 18:37:39 +0000 |
| commit | 8985e0ffc1b23ef5039383d99bdf46da10a131c1 (patch) | |
| tree | 492e6879916c33bea6fb0df157e748b1881af983 /src | |
| parent | 24223bee0e379a18db010c8b50b1b52110876caf (diff) | |
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.
Diffstat (limited to 'src')
| -rw-r--r-- | src/monomorphise.ml | 20 |
1 files changed, 12 insertions, 8 deletions
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 |