From ed95f122f3c68becc09c653471dc2982b346d343 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 13 Oct 2015 18:30:47 +0200 Subject: Fix some typos. --- plugins/extraction/mlutil.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 9fdb0205f5..6fc1195fba 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -490,8 +490,8 @@ let ast_occurs_itvl k k' t = ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true -(* Number of occurences of [Rel 1] in [t], with special treatment of match: - occurences in different branches aren't added, but we rather use max. *) +(* Number of occurrences of [Rel 1] in [t], with special treatment of match: + occurrences in different branches aren't added, but we rather use max. *) let nb_occur_match = let rec nb k = function @@ -851,7 +851,7 @@ let factor_branches o typ br = else Some (br_factor, br_set) end -(*s If all branches are functions, try to permut the case and the functions. *) +(*s If all branches are functions, try to permute the case and the functions. *) let rec merge_ids ids ids' = match ids,ids' with | [],l -> l @@ -1127,7 +1127,7 @@ let term_expunge s (ids,c) = MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurences of [MLrel r] in [t] and +(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and purge the args of [MLrel r] corresponding to a [dummy_name]. It makes eta-expansion if needed. *) @@ -1351,10 +1351,10 @@ let is_not_strict t = We expand small terms with at least one non-strict variable (i.e. a variable that may not be evaluated). - Futhermore we don't expand fixpoints. + Furthermore we don't expand fixpoints. - Moreover, as mentionned by X. Leroy (bug #2241), - inling a constant from inside an opaque module might + Moreover, as mentioned by X. Leroy (bug #2241), + inlining a constant from inside an opaque module might break types. To avoid that, we require below that both [r] and its body are globally visible. This isn't fully satisfactory, since [r] might not be visible (functor), -- cgit v1.2.3 From ec5455d7351c05a58ae99d5a300dc8576f8c9360 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 4 Dec 2015 18:39:47 +0100 Subject: Extraction: nicer implementation of Implicits Instead of the original hacks (embedding implicits in string msg in MLexn !) we now use a proper construction MLdummy (Kimplicit (r,i)) to replace the use of the i-th argument of constant or constructor r when this argument has been declared as implicit. A new option Set/Unset Extraction SafeImplicits controls what happens when some implicits still occur after an extraction : fail in safe mode, or otherwise produce some code nonetheless. This code is probably buggish if the implicits are actually used to do anything relevant (match, function call, etc), but it might also be fine if the implicits are just passed along. And anyway, this unsafe mode could help figure what's going on. Note: the MLdummy now expected a kill_reason, just as Tdummy. These kill_reason are now Ktype, Kprop (formerly Kother) and Kimplicit. Some minor refactoring on the fly. --- plugins/extraction/mlutil.ml | 90 ++++++++++++++++++++++++-------------------- 1 file changed, 49 insertions(+), 41 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 6fc1195fba..402370eece 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -299,10 +299,12 @@ let type_to_signature env t = let isKill = function Kill _ -> true | _ -> false -let isDummy = function Tdummy _ -> true | _ -> false +let isTdummy = function Tdummy _ -> true | _ -> false + +let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function - | Dummy -> Kill Kother + | Dummy -> Kill Kprop | _ -> Keep (* Classification of signatures *) @@ -310,45 +312,44 @@ let sign_of_id = function type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> - match sign_kind s with - | NonLogicalSig -> NonLogicalSig - | UnsafeLogicalSig -> UnsafeLogicalSig - | SafeLogicalSig | EmptySig -> - if k == Kother then UnsafeLogicalSig else SafeLogicalSig + match k, sign_kind s with + | _, NonLogicalSig -> NonLogicalSig + | Ktype, (SafeLogicalSig | EmptySig) -> SafeLogicalSig + | _, _ -> UnsafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> - let s' = k :: sign_no_final_keeps s in - match s' with [Keep] -> [] | _ -> s' + match k, sign_no_final_keeps s with + | Keep, [] -> [] + | k, l -> k::l (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = - let rec expunge s t = - if List.is_empty s then t else match t with - | Tmeta {contents = Some t} -> expunge s t - | Tarr (a,b) -> - let t = expunge (List.tl s) b in - if List.hd s == Keep then Tarr (a, t) else t - | Tglob (r,l) -> - (match env r with - | Some mlt -> expunge s (type_subst_list l mlt) - | None -> assert false) - | _ -> assert false + let rec expunge s t = match s, t with + | [], _ -> t + | Keep :: s, Tarr(a,b) -> Tarr (a, expunge s b) + | Kill _ :: s, Tarr(a,b) -> expunge s b + | _, Tmeta {contents = Some t} -> expunge s t + | _, Tglob (r,l) -> + (match env r with + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) + | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () != Haskell && sign_kind s == UnsafeLogicalSig then - Tarr (Tdummy Kother, t) + Tarr (Tdummy Kprop, t) else t let type_expunge env t = @@ -385,7 +386,7 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 | MLexn e1, MLexn e2 -> String.equal e1 e2 -| MLdummy, MLdummy -> true +| MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | _ -> false @@ -420,7 +421,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () in iter 0 (*s Map over asts. *) @@ -439,7 +440,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -457,7 +458,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Iter over asts. *) @@ -471,7 +472,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) @@ -507,7 +508,7 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 (*s Lifting on terms. @@ -559,7 +560,7 @@ let gen_subst v d t = if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with - | None -> MLexn ("UNBOUND " ^ string_of_int i') + | None -> assert false | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a @@ -813,8 +814,8 @@ let census_add, census_max, census_clean = try h := add k i !h with Not_found -> h := (k, Int.Set.singleton i) :: !h in - let maxf k = - let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in + let maxf () = + let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> let n = Int.Set.cardinal s in @@ -843,7 +844,7 @@ let factor_branches o typ br = if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; - let br_factor, br_set = census_max MLdummy in + let br_factor, br_set = census_max () in census_clean (); let n = Int.Set.cardinal br_set in if Int.equal n 0 then None @@ -926,7 +927,7 @@ let iota_gen br hd = in iota 0 hd let is_atomic = function - | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false @@ -998,7 +999,7 @@ and simpl_app o a = function let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) - | (MLdummy | MLexn _) as e -> e + | (MLdummy _ | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) @@ -1049,20 +1050,26 @@ let rec select_via_bl l args = match l,args with (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. - [Rels] corresponding to removed lambdas are supposed not to occur, and + [Rels] corresponding to removed lambdas are not supposed to occur + (except maybe in the case of Kimplicit), and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) +let is_impl_kill = function Kill (Kimplicit _) -> true | _ -> false + let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in if Int.equal n n' then ids,c - else if Int.equal n' 0 then [],ast_lift (-n) c + else if Int.equal n' 0 && not (List.exists is_impl_kill bl) + then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l + | Kill (Kimplicit _ as k) :: l -> + v.(i) <- Some (MLdummy k); parse_ids (i+1) j l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c @@ -1100,12 +1107,12 @@ let eta_expansion_sign s (ids,c) = let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l + | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [Del] in [s]. *) + corresponding to [Kill _] in [s]. *) let case_expunge s e = let m = List.length s in @@ -1123,8 +1130,9 @@ let term_expunge s (ids,c) = if List.is_empty s then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in - if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then - MLlam (Dummy, ast_lift 1 c) + if List.is_empty ids && lang () != Haskell && + sign_kind s == UnsafeLogicalSig + then MLlam (Dummy, ast_lift 1 c) else named_lams ids c (*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and @@ -1267,7 +1275,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l -- cgit v1.2.3 From 7d2f7e1665136f5d7a2882f733ae807e1a55dc7c Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 19:46:25 +0100 Subject: Extraction: propagate implicit args in inner fixpoint (bug #4243 part 2) In front of "let rec f x y = ... in f n m", if n is now an implicit argument, then the argument x of the inner fixpoint f is also considered as implicit. This optimization is rather ad-hoc, since we only handle MLapp(MLfix()) for now, and the implicit argument should be reused verbatim as argument. Note that it might happen that x cannot be implicit in f. But in this case we would have add an error message about n still occurring somewhere... At least this small heuristic was easy to add, and was sufficient to solve the part 2 of bug #4243. --- plugins/extraction/mlutil.ml | 61 +++++++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 24 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 402370eece..70249193e5 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1077,11 +1077,19 @@ let kill_some_lams bl (ids,c) = (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or - if there is no lambda left at all. *) + if there is no lambda left at all. In addition, it now accepts a signature + that may mention some implicits. *) -let kill_dummy_lams c = +let rec merge_implicits ids s = match ids, s with + | [],_ -> [] + | _,[] -> List.map sign_of_id ids + | Dummy::ids, _::s -> Kill Kprop :: merge_implicits ids s + | _::ids, (Kill (Kimplicit _) as k)::s -> k :: merge_implicits ids s + | _::ids, _::s -> Keep :: merge_implicits ids s + +let kill_dummy_lams sign c = let ids,c = collect_lams c in - let bl = List.map sign_of_id ids in + let bl = merge_implicits ids (List.rev sign) in if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible @@ -1093,7 +1101,7 @@ let kill_dummy_lams c = let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in - ids, named_lams ids' c + (ids,bl), named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) @@ -1135,13 +1143,13 @@ let term_expunge s (ids,c) = then MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and - purge the args of [MLrel r] corresponding to a [dummy_name]. +(*s [kill_dummy_args (ids,bl) r t] looks for occurrences of [MLrel r] in [t] + and purge the args of [MLrel r] corresponding to a [Kill] in [bl]. It makes eta-expansion if needed. *) -let kill_dummy_args ids r t = +let kill_dummy_args (ids,bl) r t = let m = List.length ids in - let bl = List.rev_map sign_of_id ids in + let sign = List.rev bl in let rec found n = function | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e @@ -1152,41 +1160,46 @@ let kill_dummy_args ids r t = let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in - let a = select_via_bl bl (a @ (eta_args k)) in + let a = select_via_bl sign (a @ (eta_args k)) in named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> - let a = select_via_bl bl (eta_args m) in + let a = select_via_bl sign (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) +let sign_of_args a = + List.map (function MLdummy k -> Kill k | _ -> Keep) a + let rec kill_dummy = function | MLfix(i,fi,c) -> (try - let ids,c = kill_dummy_fix i c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) + let k,c = kill_dummy_fix i c [] in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in + (* Heuristics: if some arguments are implicit args, we try to + eliminate the corresponding arguments of the fixpoint *) (try - let ids,c = kill_dummy_fix i c in + let k,c = kill_dummy_fix i c (sign_of_args a) in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args ids 1 fake in + let fake' = kill_dummy_args k 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try - let ids,c = kill_dummy_fix i c in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_fix i c [] in + let e = kill_dummy (kill_dummy_args k 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) @@ -1198,21 +1211,21 @@ and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a -and kill_dummy_fix i c = +and kill_dummy_fix i c s = let n = Array.length c in - let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in + let k,ci = kill_dummy_lams s (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) + c.(j) <- kill_dummy (kill_dummy_args k (n-i) c.(j)) done; - ids,c + k,c (*s Putting things together. *) -- cgit v1.2.3 From ce395ca02311bbe6ecc1b2782e74312272dd15ec Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 22:31:41 +0100 Subject: Extraction: allow basic beta-reduction even through a MLmagic (fix #2795) This fix only handles MLapp(MLmagic(MLlam...),...). Someday, we'll have to properly investigate the interaction between all the other optimizations and MLmagic. But well, at least this precise bug is fixed now. --- plugins/extraction/mlutil.ml | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 70249193e5..bfd0794de2 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -987,6 +987,10 @@ and simpl_app o a = function | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLmagic (MLlam (id,t)) -> + (* When we've at least one argument, we permute the magic + and the lambda, to simplify things a bit (see #2795) *) + simpl_app o a (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From 4b197ed247d1f30ff40fa59f85b070766f305bea Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 11:15:00 +0100 Subject: Extraction: replace unused variable names by _ in funs and matchs (fix #2842) This is done via a unique pass which seems roughly linear in practice, even on big developments like CompCert. There's a List.nth in an env at each MLrel, that could be made logarithmic if necessary via Okasaki's skew list for instance. Another approach would be to keep names (as a form of documentation), but prefix them by _ to please OCaml's warnings. For now, let's be radical and use the _ pattern. --- plugins/extraction/mlutil.ml | 69 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index bfd0794de2..2b606bf13c 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -511,6 +511,75 @@ let nb_occur_match = | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 +(* Replace unused variables by _ *) + +let dump_unused_vars a = + let dump_id = function + | Dummy -> Dummy + | Id _ -> Id dummy_name + | Tmp _ -> Tmp dummy_name + in + let rec ren env a = match a with + | MLrel i -> + let () = (List.nth env (i-1)) := true in a + + | MLlam (id,b) -> + let occ_id = ref false in + let b' = ren (occ_id::env) b in + if !occ_id then if b' == b then a else MLlam(id,b') + else MLlam(dump_id id,b') + + | MLletin (id,b,c) -> + let occ_id = ref false in + let b' = ren env b in + let c' = ren (occ_id::env) c in + if !occ_id then + if b' == b && c' == c then a else MLletin(id,b',c') + else + (* 'let' without occurrence: shouldn't happen after simpl *) + MLletin(dump_id id,b',c') + + | MLcase (t,e,br) -> + let e' = ren env e in + let br' = Array.smartmap (ren_branch env) br in + if e' == e && br' == br then a else MLcase (t,e',br') + + | MLfix (i,ids,v) -> + let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in + let v' = Array.smartmap (ren env') v in + if v' == v then a else MLfix (i,ids,v') + + | MLapp (b,l) -> + let b' = ren env b and l' = List.smartmap (ren env) l in + if b' == b && l' == l then a else MLapp (b',l') + + | MLcons(t,r,l) -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLcons (t,r,l') + + | MLtuple l -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLtuple l' + + | MLmagic b -> + let b' = ren env b in + if b' == b then a else MLmagic b' + + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a + + and ren_branch env ((ids,p,b) as tr) = + let occs = List.map (fun _ -> ref false) ids in + let b' = ren (List.rev_append occs env) b in + let ids' = + List.map2 + (fun id occ -> if !occ then id else dump_id id) + ids occs + in + if b' == b && List.equal eq_ml_ident ids ids' then tr + else (ids',p,b') + in + ren [] a + (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) -- cgit v1.2.3 From 3c535011374382bc205a68b1cb59cfa7247d544a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 17:46:25 +0100 Subject: Extraction: fix a few little glitches with my last commit (replacing unused vars by _) --- plugins/extraction/mlutil.ml | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 2b606bf13c..eb3046f031 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -514,11 +514,6 @@ let nb_occur_match = (* Replace unused variables by _ *) let dump_unused_vars a = - let dump_id = function - | Dummy -> Dummy - | Id _ -> Id dummy_name - | Tmp _ -> Tmp dummy_name - in let rec ren env a = match a with | MLrel i -> let () = (List.nth env (i-1)) := true in a @@ -527,7 +522,7 @@ let dump_unused_vars a = let occ_id = ref false in let b' = ren (occ_id::env) b in if !occ_id then if b' == b then a else MLlam(id,b') - else MLlam(dump_id id,b') + else MLlam(Dummy,b') | MLletin (id,b,c) -> let occ_id = ref false in @@ -537,7 +532,7 @@ let dump_unused_vars a = if b' == b && c' == c then a else MLletin(id,b',c') else (* 'let' without occurrence: shouldn't happen after simpl *) - MLletin(dump_id id,b',c') + MLletin(Dummy,b',c') | MLcase (t,e,br) -> let e' = ren env e in @@ -572,7 +567,7 @@ let dump_unused_vars a = let b' = ren (List.rev_append occs env) b in let ids' = List.map2 - (fun id occ -> if !occ then id else dump_id id) + (fun id occ -> if !occ then id else Dummy) ids occs in if b' == b && List.equal eq_ml_ident ids ids' then tr -- cgit v1.2.3 From 0c60735279301d22ac3e03f862f86997cb85bce0 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 16 Dec 2015 00:59:38 +0100 Subject: Extraction: fixed beta-red with Obj.magic (#2795 again) + other simplifications Unfortunately, my first attempt at replacing (Obj.magic (fun x -> u) v) by ((fun x -> Obj.magic u) v) was badly typed, as seen in FingerTree: the argument v should also be magic now, otherwise it might not have the same type as x. This optimization is now correctly done, and to mitigate the potential inflation of Obj.magic, I've added a few simplification rules to avoid redundant magics, push them down inside terms, favor the form (Obj.magic f x y z), etc. --- plugins/extraction/mlutil.ml | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index eb3046f031..d06583010f 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1035,6 +1035,13 @@ let rec simpl o = function if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | MLmagic(MLmagic _ as e) -> simpl o e + | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) + | MLmagic(MLletin(id,c,e)) -> simpl o (MLletin(id,c,MLmagic e)) + | MLmagic(MLcase(typ,e,br)) -> + let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in + simpl o (MLcase(typ,e,br')) + | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) @@ -1053,8 +1060,17 @@ and simpl_app o a = function simpl o (MLletin (id, List.hd a, MLapp (t, a')))) | MLmagic (MLlam (id,t)) -> (* When we've at least one argument, we permute the magic - and the lambda, to simplify things a bit (see #2795) *) - simpl_app o a (MLlam (id,MLmagic t)) + and the lambda, to simplify things a bit (see #2795). + Alas, the 1st argument must also be magic then. *) + let a' = match a with + | MLmagic _ :: _ -> a + | e::a' -> MLmagic e::a' + | [] -> assert false + in + simpl_app o a' (MLlam (id,MLmagic t)) + | MLmagic _ as e -> + (* When the head is magic, no need for magic on args *) + MLapp (e, List.map (function MLmagic e -> e | e -> e) a) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From 53ab313dcf7ae524a9a8312658c1e9869a4039f7 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 16 Dec 2015 11:43:53 +0100 Subject: Extraction: slightly better heuristic for Obj.magic simplifications On an application (f args) where the head is magic, we first remove Obj.magic on arguments before continuing with simplifications (that may push magic down inside the arguments). For instance, starting with ((Obj.magic f) (Obj.magic (g h))), we now end with ((Obj.magic f) (g h)) instead of ((Obj.magic f) ((Obj.magic g) h))) as before. --- plugins/extraction/mlutil.ml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index d06583010f..62724f2119 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1013,9 +1013,20 @@ let expand_linear_let o id e = (* Some beta-iota reductions + simplifications. *) +let rec unmagic = function MLmagic e -> unmagic e | e -> e +let is_magic = function MLmagic _ -> true | _ -> false +let magic_hd a = match a with + | MLmagic _ :: _ -> a + | e :: a -> MLmagic e :: a + | [] -> assert false + let rec simpl o = function | MLapp (f, []) -> simpl o f - | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) + | MLapp (MLapp(f,a),a') -> simpl o (MLapp(f,a@a')) + | MLapp (f, a) -> + (* When the head of the application is magic, no need for magic on args *) + let a = if is_magic f then List.map unmagic a else a in + simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) @@ -1047,7 +1058,6 @@ let rec simpl o = function (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function - | MLapp (f',a') -> simpl_app o (a'@a) f' | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) @@ -1062,15 +1072,7 @@ and simpl_app o a = function (* When we've at least one argument, we permute the magic and the lambda, to simplify things a bit (see #2795). Alas, the 1st argument must also be magic then. *) - let a' = match a with - | MLmagic _ :: _ -> a - | e::a' -> MLmagic e::a' - | [] -> assert false - in - simpl_app o a' (MLlam (id,MLmagic t)) - | MLmagic _ as e -> - (* When the head is magic, no need for magic on args *) - MLapp (e, List.map (function MLmagic e -> e | e -> e) a) + simpl_app o (magic_hd a) (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 17:25:10 +0100 Subject: Update copyright headers. --- plugins/extraction/mlutil.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'plugins/extraction/mlutil.ml') diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 62724f2119..402fe4ffe6 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*