diff options
| -rw-r--r-- | bytecomp/lambda.ml | 99 | ||||
| -rw-r--r-- | bytecomp/lambda.mli | 2 | ||||
| -rw-r--r-- | bytecomp/translclass.ml | 21 |
3 files changed, 83 insertions, 39 deletions
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index e1e3c0f55..7dbb60356 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -236,63 +236,88 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args -module IdentSet = - Set.Make(struct - type t = Ident.t - let compare = compare - end) - -let free_variables l = - let fv = ref IdentSet.empty in - let rec freevars = function - Lvar id -> - fv := IdentSet.add id !fv - | Lconst sc -> () +let rec iter f = function + Lvar _ + | Lconst _ -> () | Lapply(fn, args) -> - freevars fn; List.iter freevars args + f fn; List.iter f args | Lfunction(kind, params, body) -> - freevars body; - List.iter (fun param -> fv := IdentSet.remove param !fv) params + f body | Llet(str, id, arg, body) -> - freevars arg; freevars body; fv := IdentSet.remove id !fv + f arg; f body | Lletrec(decl, body) -> - freevars body; - List.iter (fun (id, exp) -> freevars exp) decl; - List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl + f body; + List.iter (fun (id, exp) -> f exp) decl | Lprim(p, args) -> - List.iter freevars args + List.iter f args | Lswitch(arg, sw) -> - freevars arg; - List.iter (fun (key, case) -> freevars case) sw.sw_consts; - List.iter (fun (key, case) -> freevars case) sw.sw_blocks; + f arg; + List.iter (fun (key, case) -> f case) sw.sw_consts; + List.iter (fun (key, case) -> f case) sw.sw_blocks; begin match sw.sw_failaction with | None -> () - | Some l -> freevars l + | Some l -> f l end | Lstaticraise (_,args) -> - List.iter freevars args + List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> - freevars e1; freevars e2 ; - List.iter (fun id -> fv := IdentSet.remove id !fv) vars + f e1; f e2 | Ltrywith(e1, exn, e2) -> - freevars e1; freevars e2; fv := IdentSet.remove exn !fv + f e1; f e2 | Lifthenelse(e1, e2, e3) -> - freevars e1; freevars e2; freevars e3 + f e1; f e2; f e3 | Lsequence(e1, e2) -> - freevars e1; freevars e2 + f e1; f e2 | Lwhile(e1, e2) -> - freevars e1; freevars e2 + f e1; f e2 | Lfor(v, e1, e2, dir, e3) -> - freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv + f e1; f e2; f e3 | Lassign(id, e) -> - fv := IdentSet.add id !fv; freevars e + f e | Lsend (k, met, obj, args) -> - List.iter freevars (met::obj::args) + List.iter f (met::obj::args) | Levent (lam, evt) -> - freevars lam + f lam | Lifused (v, e) -> - freevars e - in freevars l; !fv + f e + +module IdentSet = + Set.Make(struct + type t = Ident.t + let compare = compare + end) + +let free_ids get l = + let fv = ref IdentSet.empty in + let rec free l = + iter free l; + fv := List.fold_right IdentSet.add (get l) !fv; + match l with + Lfunction(kind, params, body) -> + List.iter (fun param -> fv := IdentSet.remove param !fv) params + | Llet(str, id, arg, body) -> + fv := IdentSet.remove id !fv + | Lletrec(decl, body) -> + List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch(e1, (_,vars), e2) -> + List.iter (fun id -> fv := IdentSet.remove id !fv) vars + | Ltrywith(e1, exn, e2) -> + fv := IdentSet.remove exn !fv + | Lfor(v, e1, e2, dir, e3) -> + fv := IdentSet.remove v !fv + | Lassign(id, e) -> + fv := IdentSet.add id !fv + | Lvar _ | Lconst _ | Lapply _ + | Lprim _ | Lswitch _ | Lstaticraise _ + | Lifthenelse _ | Lsequence _ | Lwhile _ + | Lsend _ | Levent _ | Lifused _ -> () + in free l; !fv + +let free_variables l = + free_ids (function Lvar id -> [id] | _ -> []) l + +let free_methods l = + free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l (* Check if an action has a "when" guard *) let raise_count = ref 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 42b34f0a8..87285effa 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -175,8 +175,10 @@ val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda +val iter: (lambda -> unit) -> lambda -> unit module IdentSet: Set.S with type elt = Ident.t val free_variables: lambda -> IdentSet.t +val free_methods: lambda -> IdentSet.t val transl_path: Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 79fa3a821..5583d8b0c 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -383,6 +383,16 @@ let rec build_class_lets cl = | _ -> (cl.cl_env, fun x -> x) +let rec get_class_meths cl = + match cl.cl_desc with + Tclass_structure cl -> + Meths.fold (fun _ -> IdentSet.add) cl.cl_meths IdentSet.empty + | Tclass_ident _ -> IdentSet.empty + | Tclass_fun (_, _, cl, _) + | Tclass_let (_, _, _, cl) + | Tclass_apply (cl, _) + | Tclass_constraint (cl, _, _, _) -> get_class_meths cl + (* XXX Il devrait etre peu couteux d'ecrire des classes : class c x y = d e f @@ -594,11 +604,18 @@ let transl_class ids cl_id arity pub_meths cl = let cl_env, llets = build_class_lets cl in let new_ids = if top then [] else Env.diff top_env cl_env in let env2 = Ident.create "env" in + let meth_ids = get_class_meths cl in let subst env lam i0 new_ids' = let fv = free_variables lam in let fv = List.fold_right IdentSet.remove !new_ids' fv in - let fv = - IdentSet.filter (fun id -> List.mem id new_ids) fv in + (* IdentSet.iter + (fun id -> + if not (List.mem id new_ids) then prerr_endline (Ident.name id)) + fv; *) + let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in + (* need to handle methods specially (PR#3576) *) + let fm = IdentSet.diff (free_methods lam) meth_ids in + let fv = IdentSet.union fv fm in new_ids' := !new_ids' @ IdentSet.elements fv; let i = ref (i0-1) in List.fold_left |