summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ast_util.ml3
-rw-r--r--src/ast_util.mli1
-rw-r--r--src/monomorphise.ml259
3 files changed, 198 insertions, 65 deletions
diff --git a/src/ast_util.ml b/src/ast_util.ml
index 5756c954..5c9528e2 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -433,6 +433,9 @@ let kid_loc = function
let pat_loc = function
| P_aux (_, (l, _)) -> l
+let exp_loc = function
+ | E_aux (_, (l, _)) -> l
+
let def_loc = function
| DEF_kind (KD_aux (_, (l, _)))
| DEF_type (TD_aux (_, (l, _)))
diff --git a/src/ast_util.mli b/src/ast_util.mli
index c9869cce..6a5d8c65 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -168,6 +168,7 @@ val id_loc : id -> Parse_ast.l
val kid_loc : kid -> Parse_ast.l
val pat_loc : 'a pat -> Parse_ast.l
+val exp_loc : 'a exp -> Parse_ast.l
val def_loc : 'a def -> Parse_ast.l
(* For debugging and error messages only: Not guaranteed to produce
diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 9098f03d..51c5d473 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -790,11 +790,14 @@ let construct_lit_vector args =
in aux [] args
(* We may need to split up a pattern match if (1) we've been told to case split
- on a variable by the user, or (2) we monomorphised a constructor that's used
+ on a variable by the user or analysis, or (2) we monomorphised a constructor that's used
in the pattern. *)
type split =
| NoSplit
- | VarSplit of (tannot pat * (id * tannot Ast.exp) list) list
+ | VarSplit of (tannot pat * (* pattern for this case *)
+ (id * tannot Ast.exp) list * (* substitutions for arguments *)
+ (Parse_ast.l * Parse_ast.l) list) (* optional locations of case expressions to reduce *)
+ list
| ConstrSplit of (tannot pat * nexp KBindings.t) list
let threaded_map f state l =
@@ -846,6 +849,44 @@ let keep_undef_typ value =
E_aux (E_cast (typ_of_annot eann,value),(Generated Unknown,snd eann))
| _ -> value
+let rec remove_pat_bindings p =
+ let rec aux (P_aux (p,(l,annot)) as pat) =
+ let mkp p = P_aux (p,(Generated l, annot)) in
+ match p with
+ | P_lit _
+ | P_wild -> pat
+ | P_as (p,_) -> aux p
+ | P_typ (typ,p) -> mkp (P_typ (typ,aux p))
+ | P_id id -> mkp P_wild
+ | P_var (p,_) -> aux p
+ | P_app (id,args) -> mkp (P_app (id,List.map aux args))
+ | P_record (fpats,flag) -> mkp (P_record (List.map auxr fpats,flag))
+ | P_vector ps -> mkp (P_vector (List.map aux ps))
+ | P_vector_concat ps -> mkp (P_vector_concat (List.map aux ps))
+ | P_tup ps -> mkp (P_tup (List.map aux ps))
+ | P_list ps -> mkp (P_list (List.map aux ps))
+ | P_cons (p1,p2) -> mkp (P_cons (aux p1, aux p2))
+ and auxr (FP_aux (FP_Fpat (id,p),(l,annot))) =
+ FP_aux (FP_Fpat (id, aux p),(Generated l,annot))
+ in aux p
+
+(* Use the location pairs in choices to reduce case expressions at the first
+ location to the given case at the second. *)
+let apply_pat_choices choices =
+ let rewrite_case (e,cases) =
+ match List.assoc (exp_loc e) choices with
+ | choice ->
+ let rec find = function
+ | (Pat_aux (Pat_exp (p,E_aux (e,_)),_))::_ when pat_loc p = choice -> e
+ | _::t -> find t
+ | _ -> raise (Reporting_basic.err_unreachable choice
+ "Unable to find case I found earlier!")
+ in find cases
+ | exception Not_found -> E_case (e,cases)
+ in
+ let open Rewriter in
+ fold_exp { id_exp_alg with e_case = rewrite_case }
+
let split_defs continue_anyway splits defs =
let split_constructors (Defs defs) =
let sc_type_union q (Tu_aux (tu,l) as tua) =
@@ -1289,26 +1330,26 @@ let split_defs continue_anyway splits defs =
Err_general (pat_l,
("Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v ^ ": " ^ msg))
in if continue_anyway
- then (print_error error; [P_aux (P_id var,(pat_l,annot)),[]])
+ then (print_error error; [P_aux (P_id var,(pat_l,annot)),[],[]])
else raise (Fatal_error error)
in
match ty with
| Typ_id (Id_aux (Id "bool",_)) ->
- [P_aux (P_lit (L_aux (L_true,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_true,new_l)),(new_l,annot))];
- P_aux (P_lit (L_aux (L_false,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_false,new_l)),(new_l,annot))]]
+ [P_aux (P_lit (L_aux (L_true,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_true,new_l)),(new_l,annot))],[];
+ P_aux (P_lit (L_aux (L_false,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_false,new_l)),(new_l,annot))],[]]
| Typ_id id ->
(try
(* enumerations *)
let ns = Env.get_enum id env in
List.map (fun n -> (P_aux (P_id (renew_id n),(l,annot)),
- [var,E_aux (E_id (renew_id n),(new_l,annot))])) ns
+ [var,E_aux (E_id (renew_id n),(new_l,annot))],[])) ns
with Type_error _ ->
match id with
| Id_aux (Id "bit",_) ->
List.map (fun b ->
P_aux (P_lit (L_aux (b,new_l)),(l,annot)),
- [var,E_aux (E_lit (L_aux (b,new_l)),(new_l, annot))])
+ [var,E_aux (E_lit (L_aux (b,new_l)),(new_l, annot))],[])
[L_zero; L_one]
| _ -> cannot ("don't know about type " ^ string_of_id id))
@@ -1318,7 +1359,7 @@ let split_defs continue_anyway splits defs =
let lits = make_vectors (Big_int.to_int sz) in
List.map (fun lit ->
P_aux (P_lit lit,(l,annot)),
- [var,E_aux (E_lit lit,(new_l,annot))]) lits
+ [var,E_aux (E_lit lit,(new_l,annot))],[]) lits
| _ ->
cannot ("length not constant, " ^ string_of_nexp len)
)
@@ -1328,7 +1369,7 @@ let split_defs continue_anyway splits defs =
let mk_lit i =
let lit = L_aux (L_num i,new_l) in
P_aux (P_lit lit,(l,annot)),
- [var,E_aux (E_lit lit,(new_l,annot))]
+ [var,E_aux (E_lit lit,(new_l,annot))],[]
in
match value with
| Nexp_constant i -> [mk_lit i]
@@ -1353,16 +1394,16 @@ let split_defs continue_anyway splits defs =
| Generated l -> [] (* Could do match_l l, but only want to split user-written patterns *)
| Range (p,q) ->
let matches =
- List.filter (fun ((filename,line),_) ->
+ List.filter (fun ((filename,line),_,_) ->
p.Lexing.pos_fname = filename &&
p.Lexing.pos_lnum <= line && line <= q.Lexing.pos_lnum) ls
- in List.map snd matches
+ in List.map (fun (_,var,optpats) -> (var,optpats)) matches
in
let split_pat vars p =
- let id_matches = function
- | Id_aux (Id x,_) -> List.mem x vars
- | Id_aux (DeIid x,_) -> List.mem x vars
+ let id_match = function
+ | Id_aux (Id x,_) -> (try Some (List.assoc x vars) with Not_found -> None)
+ | Id_aux (DeIid x,_) -> (try Some (List.assoc x vars) with Not_found -> None)
in
let rec list f = function
@@ -1370,45 +1411,62 @@ let split_defs continue_anyway splits defs =
| h::t ->
let t' =
match list f t with
- | None -> [t,[]]
+ | None -> [t,[],[]]
| Some t' -> t'
in
let h' =
match f h with
- | None -> [h,[]]
+ | None -> [h,[],[]]
| Some ps -> ps
in
- Some (List.concat (List.map (fun (h,hsubs) -> List.map (fun (t,tsubs) -> (h::t,hsubs@tsubs)) t') h'))
+ Some (List.concat
+ (List.map (fun (h,hsubs,hpchoices) ->
+ List.map (fun (t,tsubs,tpchoices) ->
+ (h::t, hsubs@tsubs, hpchoices@tpchoices)) t') h'))
in
let rec spl (P_aux (p,(l,annot))) =
let relist f ctx ps =
optmap (list f ps)
(fun ps ->
- List.map (fun (ps,sub) -> P_aux (ctx ps,(l,annot)),sub) ps)
+ List.map (fun (ps,sub,pchoices) -> P_aux (ctx ps,(l,annot)),sub,pchoices) ps)
in
let re f p =
optmap (spl p)
- (fun ps -> List.map (fun (p,sub) -> (P_aux (f p,(l,annot)), sub)) ps)
+ (fun ps -> List.map (fun (p,sub,pchoices) -> (P_aux (f p,(l,annot)), sub, pchoices)) ps)
in
let fpat (FP_aux ((FP_Fpat (id,p),annot))) =
optmap (spl p)
- (fun ps -> List.map (fun (p,sub) -> FP_aux (FP_Fpat (id,p), annot), sub) ps)
+ (fun ps -> List.map (fun (p,sub,pchoices) -> FP_aux (FP_Fpat (id,p), annot), sub, pchoices) ps)
in
match p with
| P_lit _
| P_wild
| P_var _
-> None
- | P_as (p',id) when id_matches id ->
+ | P_as (p',id) when id_match id <> None ->
raise (Reporting_basic.err_general l
("Cannot split " ^ string_of_id id ^ " on 'as' pattern"))
| P_as (p',id) ->
re (fun p -> P_as (p,id)) p'
| P_typ (t,p') -> re (fun p -> P_typ (t,p)) p'
- | P_id id when id_matches id ->
- Some (split id l annot)
- | P_id _ ->
- None
+ | P_id id ->
+ (match id_match id with
+ | None -> None
+ | Some None -> Some (split id l annot)
+ | Some (Some (pats,l)) ->
+ Some (List.map (fun p ->
+ let l' = pat_loc p in
+ if l' = Parse_ast.Unknown then
+ (Reporting_basic.print_error
+ (Reporting_basic.Err_general
+ (l', "No location for pattern: " ^ string_of_pat p));
+ (* If we don't have a location then attempt to continue
+ without specialising the original case expression *)
+ P_aux (P_as (remove_pat_bindings p,id),(l,annot)),[],[])
+ else
+ P_aux (P_as (remove_pat_bindings p,id),(l,annot)),[],[l,l'])
+ pats)
+ )
| P_app (id,ps) ->
relist spl (fun ps -> P_app (id,ps)) ps
| P_record (fps,flag) ->
@@ -1425,10 +1483,10 @@ let split_defs continue_anyway splits defs =
match spl p1, spl p2 with
| None, None -> None
| p1', p2' ->
- let p1' = match p1' with None -> [p1,[]] | Some p1' -> p1' in
- let p2' = match p2' with None -> [p2,[]] | Some p2' -> p2' in
- let ps = List.map (fun (p1',subs1) -> List.map (fun (p2',subs2) ->
- P_aux (P_cons (p1',p2'),(l,annot)),subs1@subs2) p2') p1' in
+ let p1' = match p1' with None -> [p1,[],[]] | Some p1' -> p1' in
+ let p2' = match p2' with None -> [p2,[],[]] | Some p2' -> p2' in
+ let ps = List.map (fun (p1',subs1,pchoices1) -> List.map (fun (p2',subs2,pchoices2) ->
+ P_aux (P_cons (p1',p2'),(l,annot)),subs1@subs2,pchoices1@pchoices2) p2') p1' in
Some (List.concat ps)
in spl p
in
@@ -1481,7 +1539,7 @@ let split_defs continue_anyway splits defs =
| lvs ->
let pvs = bindings_from_pat p in
let pvs = List.map string_of_id pvs in
- let overlap = List.exists (fun v -> List.mem v pvs) lvs in
+ let overlap = List.exists (fun (v,_) -> List.mem v pvs) lvs in
let () =
if overlap then
Reporting_basic.print_err false true l "Monomorphisation"
@@ -1569,8 +1627,9 @@ let split_defs continue_anyway splits defs =
| NoSplit -> nosplit
| VarSplit patsubsts ->
if check_split_size patsubsts (pat_loc p) then
- List.map (fun (pat',substs) ->
+ List.map (fun (pat',substs,pchoices) ->
let exp' = subst_exp substs e in
+ let exp' = apply_pat_choices pchoices exp' in
Pat_aux (Pat_exp (pat', map_exp exp'),l))
patsubsts
else nosplit
@@ -1586,9 +1645,11 @@ let split_defs continue_anyway splits defs =
| NoSplit -> nosplit
| VarSplit patsubsts ->
if check_split_size patsubsts (pat_loc p) then
- List.map (fun (pat',substs) ->
+ List.map (fun (pat',substs,pchoices) ->
let exp1' = subst_exp substs e1 in
+ let exp1' = apply_pat_choices pchoices exp1' in
let exp2' = subst_exp substs e2 in
+ let exp2' = apply_pat_choices pchoices exp2' in
Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l))
patsubsts
else nosplit
@@ -1935,11 +1996,19 @@ let id_pair_compare (id,l) (id',l') =
| 0 -> compare l l'
| x -> x
+(* Usually we do a full case split on an argument, but sometimes we find a
+ case expression in the function body that suggests a more compact case
+ splitting. *)
+type match_detail =
+ | Total
+ | Partial of tannot pat list * Parse_ast.l
+
(* Arguments that we might split on *)
-module ArgSet = Set.Make (struct
+module ArgSplits = Map.Make (struct
type t = id * loc
let compare = id_pair_compare
end)
+type arg_splits = match_detail ArgSplits.t
(* Arguments that we should look at in callers *)
module CallerArgSet = Set.Make (struct
@@ -1967,13 +2036,19 @@ module StringSet = Set.Make (struct
end)
type dependencies =
- | Have of ArgSet.t * CallerArgSet.t * CallerKidSet.t
+ | Have of arg_splits * CallerArgSet.t * CallerKidSet.t
(* args to split inside fn * caller args to split * caller kids that are bitvector parameters *)
| Unknown of Parse_ast.l * string
-let string_of_argset s =
- String.concat ", " (List.map (fun (id,l) -> string_of_id id ^ "." ^ string_of_loc l)
- (ArgSet.elements s))
+let string_of_match_detail = function
+ | Total -> "[total]"
+ | Partial (pats,_) -> "[" ^ String.concat " | " (List.map string_of_pat pats) ^ "]"
+
+let string_of_argsplits s =
+ String.concat ", "
+ (List.map (fun ((id,l),detail) ->
+ string_of_id id ^ "." ^ string_of_loc l ^ string_of_match_detail detail)
+ (ArgSplits.bindings s))
let string_of_callerset s =
String.concat ", " (List.map (fun (id,arg) -> string_of_id id ^ "." ^ string_of_int arg)
@@ -1984,8 +2059,8 @@ let string_of_callerkidset s =
(CallerKidSet.elements s))
let string_of_dep = function
- | Have (argset,callset,kidset) ->
- "Have (" ^ string_of_argset argset ^ "; " ^ string_of_callerset callset ^ "; " ^
+ | Have (args,callset,kidset) ->
+ "Have (" ^ string_of_argsplits args ^ "; " ^ string_of_callerset callset ^ "; " ^
string_of_callerkidset kidset ^ ")"
| Unknown (l,msg) -> "Unknown " ^ msg ^ " at " ^ Reporting_basic.loc_to_string l
@@ -1995,7 +2070,7 @@ let string_of_dep = function
the end for the interprocedural phase. *)
type result = {
- split : ArgSet.t;
+ split : arg_splits;
failures : StringSet.t Failures.t;
(* Dependencies for arguments and type variables of each fn called, so that
if the fn uses one for a bitvector size we can track it back *)
@@ -2005,21 +2080,27 @@ type result = {
}
let empty = {
- split = ArgSet.empty;
+ split = ArgSplits.empty;
failures = Failures.empty;
split_on_call = Bindings.empty;
split_in_caller = CallerArgSet.empty;
kid_in_caller = CallerKidSet.empty
}
+let merge_detail _ x y =
+ match x,y with
+ | None, x -> x
+ | x, None -> x
+ | Some _, Some _ -> Some Total (* TODO preserve equivalent patterns *)
+
let dmerge x y =
match x,y with
| Unknown (l,s), _ -> Unknown (l,s)
| _, Unknown (l,s) -> Unknown (l,s)
| Have (a,c,k), Have (a',c',k') ->
- Have (ArgSet.union a a', CallerArgSet.union c c', CallerKidSet.union k k')
+ Have (ArgSplits.merge merge_detail a a', CallerArgSet.union c c', CallerKidSet.union k k')
-let dempty = Have (ArgSet.empty, CallerArgSet.empty, CallerKidSet.empty)
+let dempty = Have (ArgSplits.empty, CallerArgSet.empty, CallerKidSet.empty)
let dopt_merge k x y =
match x, y with
@@ -2053,7 +2134,7 @@ let failure_merge _ x y =
| Some x, Some y -> Some (StringSet.union x y)
let merge rs rs' = {
- split = ArgSet.union rs.split rs'.split;
+ split = ArgSplits.merge merge_detail rs.split rs'.split;
failures = Failures.merge failure_merge rs.failures rs'.failures;
split_on_call = Bindings.merge call_arg_merge rs.split_on_call rs'.split_on_call;
split_in_caller = CallerArgSet.union rs.split_in_caller rs'.split_in_caller;
@@ -2150,6 +2231,36 @@ let deps_of_uvar kid_deps arg_deps = function
| U_effect _ -> dempty
| U_typ typ -> deps_of_typ kid_deps arg_deps typ
+(* If the expression matched on in a case expression is a function argument,
+ and has no other dependencies, we can try to use the pattern match directly
+ rather than doing a full case split. *)
+let refine_dependency env (E_aux (e,(l,annot)) as exp) pexps =
+ match e with
+ | E_id id ->
+ (match Bindings.find id env.var_deps with
+ | Have (args,callargs,callkids) ->
+ if CallerArgSet.is_empty callargs && CallerKidSet.is_empty callkids then
+ match ArgSplits.bindings args with
+ | [(id',loc),Total] when Id.compare id id' == 0 ->
+ (match Util.map_all (function
+ | Pat_aux (Pat_exp (pat,_),_) -> Some pat
+ | Pat_aux (Pat_when (_,_,_),_) -> None) pexps
+ with
+ | Some pats ->
+ if l = Parse_ast.Unknown then
+ (Reporting_basic.print_error
+ (Reporting_basic.Err_general
+ (l, "No location for pattern match: " ^ string_of_exp exp));
+ None)
+ else
+ Some (Have (ArgSplits.singleton (id,loc) (Partial (pats,l)),callargs,callkids))
+ | None -> None)
+ | _ -> None
+ else None
+ | Unknown _ -> None
+ | exception Not_found -> None)
+ | _ -> None
+
(* Takes an environment of dependencies on vars, type vars, and flow control,
and dependencies on mutable variables. The latter are quite conservative,
we currently drop variables assigned inside loops, for example. *)
@@ -2275,6 +2386,10 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) =
| E_field (e,_) -> analyse_exp fn_id env assigns e
| E_case (e,cases) ->
let deps,assigns,r = analyse_exp fn_id env assigns e in
+ let deps = match refine_dependency env e cases with
+ | Some deps -> deps
+ | None -> deps
+ in
let analyse_case (Pat_aux (pexp,_)) =
match pexp with
| Pat_exp (pat,e1) ->
@@ -2365,7 +2480,7 @@ let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) =
match deps_of_nexp env.kid_deps [] size with
| Have (args,caller,caller_kids) ->
{ r with
- split = ArgSet.union r.split args;
+ split = ArgSplits.merge merge_detail r.split args;
split_in_caller = CallerArgSet.union r.split_in_caller caller;
kid_in_caller = CallerKidSet.union r.kid_in_caller caller_kids
}
@@ -2422,7 +2537,7 @@ let initial_env fn_id (TypQ_aux (tq,_)) pat =
let rec aux (P_aux (p,(l,_))) =
let of_list pats =
let ss,vs,ks = split3 (List.map aux pats) in
- let s = List.fold_left ArgSet.union ArgSet.empty ss in
+ let s = List.fold_left (ArgSplits.merge merge_detail) ArgSplits.empty ss in
let v = List.fold_left dep_bindings_merge Bindings.empty vs in
let k = List.fold_left dep_kbindings_merge KBindings.empty ks in
s,v,k
@@ -2430,27 +2545,37 @@ let initial_env fn_id (TypQ_aux (tq,_)) pat =
match p with
| P_lit _
| P_wild
- -> ArgSet.empty,Bindings.empty,KBindings.empty
+ -> ArgSplits.empty,Bindings.empty,KBindings.empty
| P_as (pat,id) ->
begin
let s,v,k = aux pat in
match translate_id id with
- | Some id' -> ArgSet.add id' s, Bindings.add id (Have (ArgSet.singleton id',CallerArgSet.empty,CallerKidSet.empty)) v,k
- | None -> s, Bindings.add id (Unknown (l, ("Unable to give location for " ^ string_of_id id))) v, k
+ | Some id' ->
+ ArgSplits.add id' Total s,
+ Bindings.add id (Have (ArgSplits.singleton id' Total,CallerArgSet.empty,CallerKidSet.empty)) v,
+ k
+ | None ->
+ s,
+ Bindings.add id (Unknown (l, ("Unable to give location for " ^ string_of_id id))) v,
+ k
end
| P_typ (_,pat) -> aux pat
| P_id id ->
begin
match translate_id id with
| Some id' ->
- let s = ArgSet.singleton id' in
- s, Bindings.singleton id (Have (s,CallerArgSet.empty,CallerKidSet.empty)), KBindings.empty
+ let s = ArgSplits.singleton id' Total in
+ s,
+ Bindings.singleton id (Have (s,CallerArgSet.empty,CallerKidSet.empty)),
+ KBindings.empty
| None ->
- ArgSet.empty, Bindings.singleton id (Unknown (l, ("Unable to give location for " ^ string_of_id id))), KBindings.empty
+ ArgSplits.empty,
+ Bindings.singleton id (Unknown (l, ("Unable to give location for " ^ string_of_id id))),
+ KBindings.empty
end
| P_var (pat,kid) ->
let s,v,k = aux pat in
- s,v,KBindings.add kid (Have (ArgSet.empty,CallerArgSet.singleton (fn_id,i),CallerKidSet.empty)) k
+ s,v,KBindings.add kid (Have (ArgSplits.empty,CallerArgSet.singleton (fn_id,i),CallerKidSet.empty)) k
| P_app (_,pats) -> of_list pats
| P_record (fpats,_) -> of_list (List.map (fun (FP_aux (FP_Fpat (_,p),_)) -> p) fpats)
| P_vector pats
@@ -2463,7 +2588,7 @@ let initial_env fn_id (TypQ_aux (tq,_)) pat =
in
let quant k = function
| QI_aux (QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_,kid)),_)),_) ->
- KBindings.add kid (Have (ArgSet.empty,CallerArgSet.empty,CallerKidSet.singleton (fn_id,kid))) k
+ KBindings.add kid (Have (ArgSplits.empty,CallerArgSet.empty,CallerKidSet.singleton (fn_id,kid))) k
| QI_aux (QI_const _,_) -> k
in
let kid_quant_deps =
@@ -2477,7 +2602,7 @@ let initial_env fn_id (TypQ_aux (tq,_)) pat =
{ var_deps = var_deps; kid_deps = kid_deps }
let print_result r =
- let _ = print_endline (" splits: " ^ string_of_argset r.split) in
+ let _ = print_endline (" splits: " ^ string_of_argsplits r.split) in
let print_kbinding kid dep =
let _ = print_endline (" " ^ string_of_kid kid ^ ": " ^ string_of_dep dep) in
()
@@ -2533,25 +2658,25 @@ let analyse_defs debug env (Defs defs) =
let splits,fails = CallerKidSet.fold add_kid caller_kids (splits,fails) in
splits, fails
| Unknown (l,msg) ->
- ArgSet.empty , Failures.singleton l (StringSet.singleton ("Unable to monomorphise dependency: " ^ msg))
+ ArgSplits.empty , Failures.singleton l (StringSet.singleton ("Unable to monomorphise dependency: " ^ msg))
and chase_kid_caller (id,kid) =
match Bindings.find id r.split_on_call with
| (_,kid_deps) -> begin
match KBindings.find kid kid_deps with
| deps -> chase_deps deps
- | exception Not_found -> ArgSet.empty,Failures.empty
+ | exception Not_found -> ArgSplits.empty,Failures.empty
end
- | exception Not_found -> ArgSet.empty,Failures.empty
+ | exception Not_found -> ArgSplits.empty,Failures.empty
and chase_arg_caller (id,i) =
match Bindings.find id r.split_on_call with
| (arg_deps,_) -> chase_deps (List.nth arg_deps i)
- | exception Not_found -> ArgSet.empty,Failures.empty
+ | exception Not_found -> ArgSplits.empty,Failures.empty
and add_arg arg (splits,fails) =
let splits',fails' = chase_arg_caller arg in
- ArgSet.union splits splits', Failures.merge failure_merge fails fails'
+ ArgSplits.merge merge_detail splits splits', Failures.merge failure_merge fails fails'
and add_kid k (splits,fails) =
let splits',fails' = chase_kid_caller k in
- ArgSet.union splits splits', Failures.merge failure_merge fails fails'
+ ArgSplits.merge merge_detail splits splits', Failures.merge failure_merge fails fails'
in
let _ = if debug > 1 then print_result r else () in
let splits,fails = CallerArgSet.fold add_arg r.split_in_caller (r.split,r.failures) in
@@ -2559,7 +2684,7 @@ let analyse_defs debug env (Defs defs) =
let _ =
if debug > 0 then
(print_endline "Final splits:";
- print_endline (string_of_argset splits))
+ print_endline (string_of_argsplits splits))
else ()
in
let _ =
@@ -2573,8 +2698,11 @@ let analyse_defs debug env (Defs defs) =
in splits
let argset_to_list splits =
- let l = ArgSet.elements splits in
- let argelt (id,(file,loc)) = ((file,loc),string_of_id id) in
+ let l = ArgSplits.bindings splits in
+ let argelt = function
+ | ((id,(file,loc)),Total) -> ((file,loc),string_of_id id,None)
+ | ((id,(file,loc)),Partial (pats,l)) -> ((file,loc),string_of_id id,Some (pats,l))
+ in
List.map argelt l
end
@@ -2816,7 +2944,8 @@ let monomorphise opts splits env defs =
if opts.auto
then Analysis.argset_to_list (Analysis.analyse_defs opts.debug_analysis env defs)
else [] in
- let defs = split_defs opts.all_split_errors (new_splits@splits) defs in
+ let splits = new_splits @ (List.map (fun (loc,id) -> (loc,id,None)) splits) in
+ let defs = split_defs opts.all_split_errors splits defs in
(* TODO: stop if opts.all_split_errors && something went wrong *)
(* TODO: currently doing this because constant propagation leaves numeric literals as
int, try to avoid this later; also use final env for DEF_spec case above, because the
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-09 23:02:52 +0000