summaryrefslogtreecommitdiff
path: root/src/spec_analysis.ml
diff options
context:
space:
mode:
Diffstat (limited to 'src/spec_analysis.ml')
-rw-r--r--src/spec_analysis.ml186
1 files changed, 92 insertions, 94 deletions
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index 8cb5a796..bdbc031a 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -42,10 +42,9 @@
open Ast
open Util
-open Big_int
-open Type_internal
+open Ast_util
-type typ = Type_internal.t
+module Nameset = Set.Make(String)
let mt = Nameset.empty
@@ -58,7 +57,7 @@ let set_to_string n =
(*Query a spec for its default order if one is provided. Assumes Inc if not *)
-let get_default_order_sp (DT_aux(spec,_)) =
+(* let get_default_order_sp (DT_aux(spec,_)) =
match spec with
| DT_order (Ord_aux(o,_)) ->
(match o with
@@ -77,11 +76,11 @@ let rec default_order (Defs defs) =
| def::defs ->
match get_default_order_def def with
| None -> default_order (Defs defs)
- | Some o -> o
+ | Some o -> o *)
(*Is within range*)
-let check_in_range (candidate : big_int) (range : typ) : bool =
+(* let check_in_range (candidate : big_int) (range : typ) : bool =
match range.t with
| Tapp("range", [TA_nexp min; TA_nexp max]) | Tabbrev(_,{t=Tapp("range", [TA_nexp min; TA_nexp max])}) ->
let min,max =
@@ -182,21 +181,18 @@ let is_within_range candidate range constraints =
| _ -> Maybe)
| _ -> Maybe
-let is_within_machine64 candidate constraints = is_within_range candidate int64_t constraints
+let is_within_machine64 candidate constraints = is_within_range candidate int64_t constraints *)
(************************************************************************************************)
(*FV finding analysis: identifies the free variables of a function, expression, etc *)
-let id_to_string (Ast.Id_aux (i,_)) = match i with
- | Ast.Id s | Ast.DeIid s -> s
-
let conditional_add typ_or_exp bound used id =
let known_list =
if typ_or_exp (*true for typ*)
- then ["bit";"vector";"unit";"string";"int";"bool";"boolean"]
+ then ["bit";"vector";"unit";"string";"int";"bool"]
else ["=="; "!="; "|";"~";"&";"add_int"] in
- let i = (id_to_string id) in
- if Nameset.mem i bound || List.mem i known_list
+ let i = (string_of_id id) in
+ if Nameset.mem i bound || List.mem i known_list
then used
else Nameset.add i used
@@ -207,39 +203,32 @@ let conditional_add_exp = conditional_add false
let nameset_bigunion = List.fold_left Nameset.union mt
-let rec free_type_names_t consider_var {t = t} = match t with
- | Tvar name -> if consider_var then Nameset.add name mt else mt
- | Tid name -> Nameset.add name mt
- | Tfn (t1,t2,_,_) -> Nameset.union (free_type_names_t consider_var t1)
- (free_type_names_t consider_var t2)
- | Ttup ts -> free_type_names_ts consider_var ts
- | Tapp (name,targs) -> Nameset.add name (free_type_names_t_args consider_var targs)
- | Tabbrev (t1,t2) -> Nameset.union (free_type_names_t consider_var t1)
+let rec free_type_names_t consider_var (Typ_aux (t, _)) = match t with
+ | Typ_var name -> if consider_var then Nameset.add (string_of_kid name) mt else mt
+ | Typ_id name -> Nameset.add (string_of_id name) mt
+ | Typ_fn (t1,t2,_) -> Nameset.union (free_type_names_t consider_var t1)
(free_type_names_t consider_var t2)
- | Toptions (t,m_t) -> Nameset.union (free_type_names_t consider_var t)
- (free_type_names_maybe_t consider_var m_t)
- | Tuvar _ -> mt
+ | Typ_tup ts -> free_type_names_ts consider_var ts
+ | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs)
+ | Typ_exist (kids,_,t') -> List.fold_left (fun s kid -> Nameset.remove (string_of_kid kid) s) (free_type_names_t consider_var t') kids
and free_type_names_ts consider_var ts = nameset_bigunion (List.map (free_type_names_t consider_var) ts)
and free_type_names_maybe_t consider_var = function
| Some t -> free_type_names_t consider_var t
| None -> mt
and free_type_names_t_arg consider_var = function
- | TA_typ t -> free_type_names_t consider_var t
+ | Typ_arg_aux (Typ_arg_typ t, _) -> free_type_names_t consider_var t
| _ -> mt
and free_type_names_t_args consider_var targs =
nameset_bigunion (List.map (free_type_names_t_arg consider_var) targs)
let rec free_type_names_tannot consider_var = function
- | NoTyp -> mt
- | Base ((_,t),_ ,_,_,_,_) -> free_type_names_t consider_var t
- | Overload (tannot,_,tannots) ->
- nameset_bigunion (List.map (free_type_names_tannot consider_var) (tannot :: tannots))
+ | None -> mt
+ | Some (_, t, _) -> free_type_names_t consider_var t
let rec fv_of_typ consider_var bound used (Typ_aux (t,_)) : Nameset.t =
match t with
- | Typ_wild -> used
| Typ_var (Kid_aux (Var v,l)) ->
if consider_var
then conditional_add_typ bound used (Ast.Id_aux (Ast.Id v,l))
@@ -248,7 +237,8 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,_)) : Nameset.t =
| Typ_fn(arg,ret,_) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used arg) ret
| Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used
| Typ_app(id,targs) ->
- List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id)
+ List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id)
+ | Typ_exist (kids,_,t') -> fv_of_typ consider_var (List.fold_left (fun b (Kid_aux (Var v,_)) -> Nameset.add v b) bound kids) used t'
and fv_of_targ consider_var bound used (Ast.Typ_arg_aux(targ,_)) : Nameset.t = match targ with
| Typ_arg_typ t -> fv_of_typ consider_var bound used t
@@ -285,22 +275,20 @@ let rec pat_bindings consider_var bound used (P_aux(p,(_,tannot))) =
let list_fv bound used ps = List.fold_right (fun p (b,n) -> pat_bindings consider_var b n p) ps (bound, used) in
match p with
| P_as(p,id) -> let b,ns = pat_bindings consider_var bound used p in
- Nameset.add (id_to_string id) b,ns
+ Nameset.add (string_of_id id) b,ns
| P_typ(t,p) ->
let used = Nameset.union (free_type_names_tannot consider_var tannot) used in
let ns = fv_of_typ consider_var bound used t in pat_bindings consider_var bound ns p
| P_id id ->
let used = Nameset.union (free_type_names_tannot consider_var tannot) used in
- Nameset.add (id_to_string id) bound,used
+ Nameset.add (string_of_id id) bound,used
| P_app(id,pats) ->
let used = Nameset.union (free_type_names_tannot consider_var tannot) used in
- list_fv bound (Nameset.add (id_to_string id) used) pats
+ list_fv bound (Nameset.add (string_of_id id) used) pats
| P_record(fpats,_) ->
List.fold_right (fun (Ast.FP_aux(Ast.FP_Fpat(_,p),_)) (b,n) ->
pat_bindings consider_var bound used p) fpats (bound,used)
| P_vector pats | Ast.P_vector_concat pats | Ast.P_tup pats | Ast.P_list pats -> list_fv bound used pats
- | P_vector_indexed ipats ->
- List.fold_right (fun (_,p) (b,n) -> pat_bindings consider_var b n p) ipats (bound,used)
| _ -> bound,used
let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset.t * Nameset.t * Nameset.t) =
@@ -324,14 +312,8 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset.
| E_if(c,t,e) -> list_fv bound used set [c;t;e]
| E_for(id,from,to_,by,_,body) ->
let _,used,set = list_fv bound used set [from;to_;by] in
- fv_of_exp consider_var (Nameset.add (id_to_string id) bound) used set body
- | E_vector_indexed (es_i,(Ast.Def_val_aux(default,_))) ->
- let bound,used,set =
- List.fold_right
- (fun (_,e) (b,u,s) -> fv_of_exp consider_var b u s e) es_i (bound,used,set) in
- (match default with
- | Def_val_empty -> bound,used,set
- | Def_val_dec e -> fv_of_exp consider_var bound used set e)
+ fv_of_exp consider_var (Nameset.add (string_of_id id) bound) used set body
+ | E_loop(_, cond, body) -> list_fv bound used set [cond; body]
| E_vector_access(v,i) -> list_fv bound used set [v;i]
| E_vector_subrange(v,i1,i2) -> list_fv bound used set [v;i1;i2]
| E_vector_update(v,i,e) -> list_fv bound used set [v;i;e]
@@ -358,6 +340,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset.
b,used,set
| E_exit e -> fv_of_exp consider_var bound used set e
| E_assert(c,m) -> list_fv bound used set [c;m]
+ | E_return e -> fv_of_exp consider_var bound used set e
| _ -> bound,used,set
and fv_of_pes consider_var bound used set pes =
@@ -367,14 +350,14 @@ and fv_of_pes consider_var bound used set pes =
let bound_p,us_p = pat_bindings consider_var bound used p in
let bound_e,us_e,set_e = fv_of_exp consider_var bound_p us_p set e in
fv_of_pes consider_var bound us_e set_e pes
+ | Pat_aux(Pat_when (p,g,e),_)::pes ->
+ let bound_p,us_p = pat_bindings consider_var bound used p in
+ let bound_g,us_g,set_g = fv_of_exp consider_var bound_p us_p set g in
+ let bound_e,us_e,set_e = fv_of_exp consider_var bound_g us_g set_g e in
+ fv_of_pes consider_var bound us_e set_e pes
and fv_of_let consider_var bound used set (LB_aux(lebind,_)) = match lebind with
- | LB_val_explicit(typsch,pat,exp) ->
- let bound_t,us_t = fv_of_typschm consider_var bound used typsch in
- let bound_p, us_p = pat_bindings consider_var (Nameset.union bound bound_t) used pat in
- let _,us_e,set_e = fv_of_exp consider_var (Nameset.union bound bound_t) used set exp in
- (Nameset.union bound_t bound_p),Nameset.union us_t (Nameset.union us_p us_e),set_e
- | LB_val_implicit(pat,exp) ->
+ | LB_val(pat,exp) ->
let bound_p, us_p = pat_bindings consider_var bound used pat in
let _,us_e,set_e = fv_of_exp consider_var bound used set exp in
bound_p,Nameset.union us_p us_e,set_e
@@ -383,13 +366,13 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) =
match lexp with
| LEXP_id id ->
let used = Nameset.union (free_type_names_tannot consider_var tannot) used in
- let i = id_to_string id in
+ let i = string_of_id id in
if Nameset.mem i bound
then bound, used, Nameset.add i set
else Nameset.add i bound, Nameset.add i used, set
| LEXP_cast(typ,id) ->
let used = Nameset.union (free_type_names_tannot consider_var tannot) used in
- let i = id_to_string id in
+ let i = string_of_id id in
let used_t = fv_of_typ consider_var bound used typ in
if Nameset.mem i bound
then bound, used_t, Nameset.add i set
@@ -401,7 +384,7 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) =
List.fold_right
(fun e (b,u,s) ->
fv_of_exp consider_var b u s e) args (bound,used,set) in
- bound,Nameset.add (id_to_string id) used,set
+ bound,Nameset.add (string_of_id id) used,set
| LEXP_field(lexp,_) -> fv_of_lexp consider_var bound used set lexp
| LEXP_vector(lexp,exp) ->
let bound_l,used,set = fv_of_lexp consider_var bound used set lexp in
@@ -418,47 +401,36 @@ let init_env s = Nameset.singleton s
let typ_variants consider_var bound tunions =
List.fold_right
(fun (Tu_aux(t,_)) (b,n) -> match t with
- | Tu_id id -> Nameset.add (id_to_string id) b,n
- | Tu_ty_id(t,id) -> Nameset.add (id_to_string id) b, fv_of_typ consider_var b n t)
+ | Tu_id id -> Nameset.add (string_of_id id) b,n
+ | Tu_ty_id(t,id) -> Nameset.add (string_of_id id) b, fv_of_typ consider_var b n t)
tunions
(bound,mt)
let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with
- | KD_nabbrev(_,id,_,nexp) -> init_env (id_to_string id), fv_of_nexp consider_var mt mt nexp
- | KD_abbrev(_,id,_,typschm) ->
- init_env (id_to_string id), snd (fv_of_typschm consider_var mt mt typschm)
- | KD_record(_,id,_,typq,tids,_) ->
- let binds = init_env (id_to_string id) in
- let bounds = if consider_var then typq_bindings typq else mt in
- binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt
- | KD_variant(_,id,_,typq,tunions,_) ->
- let bindings = Nameset.add (id_to_string id) (if consider_var then typq_bindings typq else mt) in
- typ_variants consider_var bindings tunions
- | KD_enum(_,id,_,ids,_) ->
- Nameset.of_list (List.map id_to_string (id::ids)),mt
- | KD_register(_,id,n1,n2,_) ->
- init_env (id_to_string id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2
+ | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp
let fv_of_type_def consider_var (TD_aux(t,_)) = match t with
- | TD_abbrev(id,_,typschm) -> init_env (id_to_string id), snd (fv_of_typschm consider_var mt mt typschm)
+ | TD_abbrev(id,_,typschm) -> init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm)
| TD_record(id,_,typq,tids,_) ->
- let binds = init_env (id_to_string id) in
+ let binds = init_env (string_of_id id) in
let bounds = if consider_var then typq_bindings typq else mt in
binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt
| TD_variant(id,_,typq,tunions,_) ->
- let bindings = Nameset.add (id_to_string id) (if consider_var then typq_bindings typq else mt) in
+ let bindings = Nameset.add (string_of_id id) (if consider_var then typq_bindings typq else mt) in
typ_variants consider_var bindings tunions
| TD_enum(id,_,ids,_) ->
- Nameset.of_list (List.map id_to_string (id::ids)),mt
+ Nameset.of_list (List.map string_of_id (id::ids)),mt
| TD_register(id,n1,n2,_) ->
- init_env (id_to_string id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2
+ init_env (string_of_id id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2
let fv_of_tannot_opt consider_var (Typ_annot_opt_aux (t,_)) =
match t with
| Typ_annot_opt_some (typq,typ) ->
let bindings = if consider_var then typq_bindings typq else mt in
let free = fv_of_typ consider_var bindings mt typ in
- (bindings,free)
+ (bindings,free)
+ | Typ_annot_opt_none ->
+ (mt, mt)
(*Unlike the other fv, the bound returns are the names bound by the pattern for use in the exp*)
let fv_of_funcl consider_var base_bounds (FCL_aux(FCL_Funcl(id,pat,exp),l)) =
@@ -466,10 +438,10 @@ let fv_of_funcl consider_var base_bounds (FCL_aux(FCL_Funcl(id,pat,exp),l)) =
let _, exp_ns, exp_sets = fv_of_exp consider_var pat_bs pat_ns mt exp in
(pat_bs,exp_ns,exp_sets)
-let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_)) =
+let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_) as fd) =
let fun_name = match funcls with
| [] -> failwith "fv_of_fun fell off the end looking for the function name"
- | FCL_aux(FCL_Funcl(id,_,_),_)::_ -> id_to_string id in
+ | FCL_aux(FCL_Funcl(id,_,_),_)::_ -> string_of_id id in
let base_bounds = match rec_opt with
| Rec_aux(Ast.Rec_rec,_) -> init_env fun_name
| _ -> mt in
@@ -477,16 +449,20 @@ let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_))
| Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ),_) ->
let bindings = if consider_var then typq_bindings typq else mt in
let bound = Nameset.union bindings base_bounds in
- bound, fv_of_typ consider_var bound mt typ in
+ bound, fv_of_typ consider_var bound mt typ
+ | Typ_annot_opt_aux(Typ_annot_opt_none, _) ->
+ base_bounds, mt in
let ns = List.fold_right (fun (FCL_aux(FCL_Funcl(_,pat,exp),_)) ns ->
let pat_bs,pat_ns = pat_bindings consider_var base_bounds ns pat in
let _, exp_ns,_ = fv_of_exp consider_var pat_bs pat_ns Nameset.empty exp in
exp_ns) funcls mt in
- init_env fun_name,Nameset.union ns ns_r
+ let ns_vs = init_env ("val:" ^ (string_of_id (id_of_fundef fd))) in
+ (* let _ = Printf.eprintf "Function %s uses %s\n" fun_name (set_to_string (Nameset.union ns ns_r)) in *)
+ init_env fun_name, Nameset.union ns_vs (Nameset.union ns ns_r)
let fv_of_vspec consider_var (VS_aux(vspec,_)) = match vspec with
- | VS_val_spec(ts,id) | VS_extern_no_rename (ts,id) | VS_extern_spec(ts,id,_)->
- init_env ("val:" ^ (id_to_string id)), snd (fv_of_typschm consider_var mt mt ts)
+ | VS_val_spec(ts,id,_,_) ->
+ init_env ("val:" ^ (string_of_id id)), snd (fv_of_typschm consider_var mt mt ts)
let rec find_scattered_of name = function
| [] -> []
@@ -495,7 +471,7 @@ let rec find_scattered_of name = function
| SD_scattered_function(_,_,_,id)
| SD_scattered_funcl(FCL_aux(FCL_Funcl(id,_,_),_))
| SD_scattered_unioncl(id,_) ->
- if name = id_to_string id
+ if name = string_of_id id
then [sd] else []
| _ -> [])@
(find_scattered_of name defs)
@@ -506,17 +482,19 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd
let b,ns = (match tannot_opt with
| Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ),_) ->
let bindings = if consider_var then typq_bindings typq else mt in
- bindings, fv_of_typ consider_var bindings mt typ) in
- init_env (id_to_string id),ns
+ bindings, fv_of_typ consider_var bindings mt typ
+ | Typ_annot_opt_aux(Typ_annot_opt_none, _) ->
+ mt, mt) in
+ init_env (string_of_id id),ns
| SD_scattered_funcl (FCL_aux(FCL_Funcl(id,pat,exp),_)) ->
let pat_bs,pat_ns = pat_bindings consider_var mt mt pat in
let _,exp_ns,_ = fv_of_exp consider_var pat_bs pat_ns Nameset.empty exp in
let scattered_binds = match pat with
- | P_aux(P_app(pid,_),_) -> init_env ((id_to_string id) ^ "/" ^ (id_to_string pid))
+ | P_aux(P_app(pid,_),_) -> init_env ((string_of_id id) ^ "/" ^ (string_of_id pid))
| _ -> mt in
scattered_binds, exp_ns
| SD_scattered_variant (id,_,_) ->
- let name = id_to_string id in
+ let name = string_of_id id in
let uses =
if consider_scatter_as_one
then
@@ -528,12 +506,12 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd
else mt in
init_env name, uses
| SD_scattered_unioncl(id, type_union) ->
- let typ_name = id_to_string id in
+ let typ_name = string_of_id id in
let b = init_env typ_name in
let (b,r) = typ_variants consider_var b [type_union] in
(Nameset.remove typ_name b, Nameset.add typ_name r)
| SD_scattered_end id ->
- let name = id_to_string id in
+ let name = string_of_id id in
let uses = if consider_scatter_as_one
(*Note: if this is a function ending, the dec is included *)
then
@@ -545,11 +523,11 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd
let fv_of_rd consider_var (DEC_aux (d,_)) = match d with
| DEC_reg(t,id) ->
- init_env (id_to_string id), fv_of_typ consider_var mt mt t
+ init_env (string_of_id id), fv_of_typ consider_var mt mt t
| DEC_alias(id,alias) ->
- init_env (id_to_string id),mt
+ init_env (string_of_id id),mt
| DEC_typ_alias(t,id,alias) ->
- init_env (id_to_string id), mt
+ init_env (string_of_id id), mt
let fv_of_def consider_var consider_scatter_as_one all_defs = function
| DEF_kind kdef -> fv_of_kind_def consider_var kdef
@@ -557,6 +535,8 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function
| DEF_fundef fdef -> fv_of_fun consider_var fdef
| DEF_val lebind -> ((fun (b,u,_) -> (b,u)) (fv_of_let consider_var mt mt mt lebind))
| DEF_spec vspec -> fv_of_vspec consider_var vspec
+ | DEF_fixity _ -> mt,mt
+ | DEF_overload (id,ids) -> init_env (string_of_id id), List.fold_left (fun ns id -> Nameset.add (string_of_id id) ns) mt ids
| DEF_default def -> mt,mt
| DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef
| DEF_reg_dec rdec -> fv_of_rd consider_var rdec
@@ -596,6 +576,20 @@ let rec print_dependencies orig_queue work_queue names =
print_dependencies orig_queue orig_queue uses));
print_dependencies orig_queue wq names
+let merge_mutrecs defs =
+ let merge_aux ((binds', uses'), def) ((binds, uses), fundefs) =
+ let fundefs = match def with
+ | DEF_fundef fundef -> fundef :: fundefs
+ | DEF_internal_mutrec fundefs' -> fundefs' @ fundefs
+ | _ ->
+ (* let _ = Pretty_print_sail2.pp_defs stderr (Defs [def]) in *)
+ raise (Reporting_basic.err_unreachable (def_loc def)
+ "Trying to merge non-function definition with mutually recursive functions") in
+ (* let _ = Printf.eprintf " - Merging %s (using %s)\n" (set_to_string binds') (set_to_string uses') in *)
+ ((Nameset.union binds' binds, Nameset.union uses' uses), fundefs) in
+ let ((binds, uses), fundefs) = List.fold_right merge_aux defs ((mt, mt), []) in
+ ((binds, uses), DEF_internal_mutrec fundefs)
+
let rec topological_sort work_queue defs =
match work_queue with
| [] -> List.rev defs
@@ -609,11 +603,15 @@ let rec topological_sort work_queue defs =
else
match List.stable_sort compare_dbts work_queue with (*We wait to sort until there are no 0 dependency nodes on top*)
| [] -> failwith "sort shrunk the list???"
- | (((n,uses),_)::_) as wq ->
+ | (((n,uses),def)::rest) as wq ->
if (Nameset.cardinal uses = 0)
then topological_sort wq defs
- else let _ = Printf.eprintf "Uses on failure are %s, binds are %s\n" (set_to_string uses) (set_to_string n)
- in let _ = print_dependencies wq wq uses in failwith "A dependency was unmet"
+ else
+ let _ = Printf.eprintf "Merging (potentially) mutually recursive definitions %s and %s\n" (set_to_string n) (set_to_string uses) in
+ let is_used ((binds', uses'), def') = not(Nameset.is_empty(Nameset.inter binds' uses)) in
+ let (used, rest) = List.partition is_used rest in
+ let wq = merge_mutrecs (((n,uses),def)::used) :: rest in
+ topological_sort wq defs
let rec add_to_partial_order ((binds,uses),def) = function
| [] ->
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 23:32:08 +0000