diff options
Diffstat (limited to 'src/constant_propagation.ml')
| -rw-r--r-- | src/constant_propagation.ml | 160 |
1 files changed, 77 insertions, 83 deletions
diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index 51d079e9..608d25e1 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -110,7 +110,7 @@ let rec is_value (E_aux (e,(l,annot))) = match e with | E_id id -> is_constructor id | E_lit _ -> true - | E_tuple es -> List.for_all is_value es + | E_tuple es | E_vector es -> List.for_all is_value es | E_record fes -> List.for_all (fun (FE_aux (FE_Fexp (_, e), _)) -> is_value e) fes | E_app (id,es) -> is_constructor id && List.for_all is_value es @@ -655,9 +655,22 @@ let const_props defs ref_vars = | _ -> exp and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = - let rec check_exp_pat (E_aux (e,(l,annot))) (P_aux (p,(l',_))) = - match e with - | E_id id -> + let rec check_exp_pat (E_aux (e,(l,annot)) as exp) (P_aux (p,(l',_)) as pat) = + match e, p with + | _, P_wild -> DoesMatch ([],[]) + | _, P_typ (_,p') -> check_exp_pat exp p' + | _, P_id id' when pat_id_is_variable env id' -> DoesMatch ([id',exp],[]) + | E_tuple es, P_tup ps -> + let rec check = function + | DoesNotMatch -> fun _ -> DoesNotMatch + | GiveUp -> fun _ -> GiveUp + | DoesMatch (s,ns) -> + fun (e,p) -> + match check_exp_pat e p with + | DoesMatch (s',ns') -> DoesMatch (s@s', ns@ns') + | x -> x + in List.fold_left check (DoesMatch ([],[])) (List.combine es ps) + | E_id id, _ -> (match Env.lookup_id id env with | Enum _ -> begin match p with @@ -669,95 +682,76 @@ let const_props defs ref_vars = "Unexpected kind of pattern for enumeration"; GiveUp) end | _ -> GiveUp) - | E_lit (L_aux (lit_e, lit_l)) -> begin - match p with - | P_lit (L_aux (lit_p, _)) -> - if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch - | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> - begin - match lit_e with - | L_num i -> - DoesMatch ([id, E_aux (e,(l,annot))], - [kid,Nexp_aux (Nexp_constant i,Unknown)]) - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - | L_undef -> - let nexp = fabricate_nexp l annot in - let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], - [kid,nexp]) - | _ -> - (Reporting.print_err lit_l "Monomorphisation" - "Unexpected kind of literal for var match"; GiveUp) - end - | _ -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - end - | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> begin - match p with - | P_vector ps -> - let matches = List.map2 (fun e p -> - match e, p with - | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> - if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch - | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> - DoesMatch ([var, e],[]) - | _ -> GiveUp) es ps in - let final = List.fold_left (fun acc m -> match acc, m with - | _, GiveUp -> GiveUp - | GiveUp, _ -> GiveUp - | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') - | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in - (match final with - | GiveUp -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - | _ -> final) - | _ -> + | E_lit (L_aux (lit_e, lit_l)), P_lit (L_aux (lit_p, _)) -> + if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch + | E_lit (L_aux (lit_e, lit_l)), + P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + begin + match lit_e with + | L_num i -> + DoesMatch ([id, E_aux (e,(l,annot))], + [kid,Nexp_aux (Nexp_constant i,Unknown)]) + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + | L_undef -> + let nexp = fabricate_nexp l annot in + let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], + [kid,nexp]) + | _ -> + (Reporting.print_err lit_l "Monomorphisation" + "Unexpected kind of literal for var match"; GiveUp) + end + | E_lit _, _ -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + | E_vector es, P_vector ps + when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> + let matches = List.map2 (fun e p -> + match e, p with + | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> + if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch + | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> + DoesMatch ([var, e],[]) + | _ -> GiveUp) es ps in + let final = List.fold_left (fun acc m -> match acc, m with + | _, GiveUp -> GiveUp + | GiveUp, _ -> GiveUp + | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') + | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in + (match final with + | GiveUp -> (Reporting.print_err l "Monomorphisation" "Unexpected kind of pattern for vector literal"; GiveUp) - end - | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> begin - match p with - | P_lit (L_aux (lit_p, _)) -> DoesNotMatch - | P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - let nexp = fabricate_nexp l annot in - let kids = equal_kids (env_of_annot p_id_annot) kid in - let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in - let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], - KBindings.bindings ksubst) - | _ -> + | _ -> final) + | E_vector _, _ -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), + P_lit (L_aux (lit_p, _)) + -> DoesNotMatch + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), + P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)) -> + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + let nexp = fabricate_nexp l annot in + let kids = equal_kids (env_of_annot p_id_annot) kid in + let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in + let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], + KBindings.bindings ksubst) + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)), _ -> (Reporting.print_err l' "Monomorphisation" "Unexpected kind of pattern for literal"; GiveUp) - end - | E_record _ | E_cast (_, E_aux (E_record _, _)) -> DoesNotMatch + | E_record _,_ | E_cast (_, E_aux (E_record _, _)),_ -> DoesNotMatch | _ -> GiveUp in let check_pat = check_exp_pat exp0 in let rec findpat_generic description assigns = function | [] -> (Reporting.print_err l "Monomorphisation" ("Failed to find a case for " ^ description); None) - | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) - | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> - findpat_generic description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) - | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx - when pat_id_is_variable env id' -> - Some (exp, [(id', exp0)], []) - | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl - when pat_id_is_variable env id' -> begin - let substs = Bindings.add id' exp0 substs, ksubsts in - let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in - match guard with - | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) - | E_lit (L_aux (L_false,_)) -> findpat_generic description assigns tl - | _ -> None - end | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin match check_pat p with | DoesNotMatch -> findpat_generic description assigns tl |