diff options
Diffstat (limited to 'ocaml-binary-annot/bytecomp/lambda.ml')
| -rw-r--r-- | ocaml-binary-annot/bytecomp/lambda.ml | 425 |
1 files changed, 425 insertions, 0 deletions
diff --git a/ocaml-binary-annot/bytecomp/lambda.ml b/ocaml-binary-annot/bytecomp/lambda.ml new file mode 100644 index 0000000000..ff94a6d9cc --- /dev/null +++ b/ocaml-binary-annot/bytecomp/lambda.ml @@ -0,0 +1,425 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Misc +open Path +open Asttypes + +type primitive = + Pidentity + | Pignore + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag + | Pfield of int + | Psetfield of int * bool + | Pfloatfield of int + | Psetfloatfield of int + | Pduprecord of Types.record_representation * int + (* Force lazy values *) + | Plazyforce + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets + (* Array operations *) + | Pmakearray of array_kind + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Bitvect operations *) + | Pbittest + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of boxed_integer + | Pmodbint of boxed_integer + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * comparison + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + +and comparison = + Ceq | Cneq | Clt | Cgt | Cle | Cge + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + | Const_immstring of string + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable + +type meth_kind = Self | Public | Cached + +type shared_code = (int * int) list + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda * lambda list * Location.t + | Lfunction of function_kind * Ident.t list * lambda + | Llet of let_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list + | Lswitch of lambda * lambda_switch + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of meth_kind * lambda * lambda * lambda list + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lambda_switch = + { sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction : lambda option} + +and lambda_event = + { lev_loc: Location.t; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.summary } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + +let const_unit = Const_pointer 0 + +let lambda_unit = Lconst const_unit + +let rec same l1 l2 = + match (l1, l2) with + | Lvar v1, Lvar v2 -> + Ident.same v1 v2 + | Lconst c1, Lconst c2 -> + c1 = c2 + | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> + same a1 a2 && samelist same bl1 bl2 + | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> + k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 + | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> + k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 + | Lletrec (bl1, a1), Lletrec (bl2, a2) -> + samelist samebinding bl1 bl2 && same a1 a2 + | Lprim(p1, al1), Lprim(p2, al2) -> + p1 = p2 && samelist same al1 al2 + | Lswitch(a1, s1), Lswitch(a2, s2) -> + same a1 a2 && sameswitch s1 s2 + | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> + n1 = n2 && samelist same al1 al2 + | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> + same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 + | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> + same a1 a2 && Ident.same id1 id2 && same b1 b2 + | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> + same a1 a2 && same b1 b2 && same c1 c2 + | Lsequence(a1, b1), Lsequence(a2, b2) -> + same a1 a2 && same b1 b2 + | Lwhile(a1, b1), Lwhile(a2, b2) -> + same a1 a2 && same b1 b2 + | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> + Ident.same id1 id2 && same a1 a2 && + same b1 b2 && df1 = df2 && same c1 c2 + | Lassign(id1, a1), Lassign(id2, a2) -> + Ident.same id1 id2 && same a1 a2 + | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) -> + k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 + | Levent(a1, ev1), Levent(a2, ev2) -> + same a1 a2 && ev1.lev_loc = ev2.lev_loc + | Lifused(id1, a1), Lifused(id2, a2) -> + Ident.same id1 id2 && same a1 a2 + | _, _ -> + false + +and samebinding (id1, c1) (id2, c2) = + Ident.same id1 id2 && same c1 c2 + +and sameswitch sw1 sw2 = + let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in + sw1.sw_numconsts = sw2.sw_numconsts && + sw1.sw_numblocks = sw2.sw_numblocks && + samelist samecase sw1.sw_consts sw2.sw_consts && + samelist samecase sw1.sw_blocks sw2.sw_blocks && + (match (sw1.sw_failaction, sw2.sw_failaction) with + | (None, None) -> true + | (Some a1, Some a2) -> same a1 a2 + | _ -> false) + +let name_lambda arg fn = + match arg with + Lvar id -> fn id + | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + +let name_lambda_list args fn = + let rec name_list names = function + [] -> fn (List.rev names) + | (Lvar id as arg) :: rem -> + name_list (arg :: names) rem + | arg :: rem -> + let id = Ident.create "let" in + Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in + name_list [] args + +let rec iter f = function + Lvar _ + | Lconst _ -> () + | Lapply(fn, args, _) -> + f fn; List.iter f args + | Lfunction(kind, params, body) -> + f body + | Llet(str, id, arg, body) -> + f arg; f body + | Lletrec(decl, body) -> + f body; + List.iter (fun (id, exp) -> f exp) decl + | Lprim(p, args) -> + List.iter f args + | Lswitch(arg, sw) -> + 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 -> f l + end + | Lstaticraise (_,args) -> + List.iter f args + | Lstaticcatch(e1, (_,vars), e2) -> + f e1; f e2 + | Ltrywith(e1, exn, e2) -> + f e1; f e2 + | Lifthenelse(e1, e2, e3) -> + f e1; f e2; f e3 + | Lsequence(e1, e2) -> + f e1; f e2 + | Lwhile(e1, e2) -> + f e1; f e2 + | Lfor(v, e1, e2, dir, e3) -> + f e1; f e2; f e3 + | Lassign(id, e) -> + f e + | Lsend (k, met, obj, args) -> + List.iter f (met::obj::args) + | Levent (lam, evt) -> + f lam + | Lifused (v, e) -> + 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 + +let next_raise_count () = + incr raise_count ; + !raise_count + +(* Anticipated staticraise, for guards *) +let staticfail = Lstaticraise (0,[]) + +let rec is_guarded = function + | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true + | Llet(str, id, lam, body) -> is_guarded body + | Levent(lam, ev) -> is_guarded lam + | _ -> false + +let rec patch_guarded patch = function + | Lifthenelse (cond, body, Lstaticraise (0,[])) -> + Lifthenelse (cond, body, patch) + | Llet(str, id, lam, body) -> + Llet (str, id, lam, patch_guarded patch body) + | Levent(lam, ev) -> + Levent (patch_guarded patch lam, ev) + | _ -> fatal_error "Lambda.patch_guarded" + +(* Translate an access path *) + +let rec transl_path = function + Pident id -> + if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id + | Pdot(p, s, pos) -> + Lprim(Pfield pos, [transl_path p]) + | Papply(p1, p2) -> + fatal_error "Lambda.transl_path" + +(* Compile a sequence of expressions *) + +let rec make_sequence fn = function + [] -> lambda_unit + | [x] -> fn x + | x::rem -> + let lam = fn x in Lsequence(lam, make_sequence fn rem) + +(* Apply a substitution to a lambda-term. + Assumes that the bound variables of the lambda-term do not + belong to the domain of the substitution. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +let subst_lambda s lam = + let rec subst = function + Lvar id as l -> + begin try Ident.find_same id s with Not_found -> l end + | Lconst sc as l -> l + | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) + | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) + | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) + | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) + | Lprim(p, args) -> Lprim(p, List.map subst args) + | Lswitch(arg, sw) -> + Lswitch(subst arg, + {sw with sw_consts = List.map subst_case sw.sw_consts; + sw_blocks = List.map subst_case sw.sw_blocks; + sw_failaction = + match sw.sw_failaction with + | None -> None + | Some l -> Some (subst l)}) + + | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) + | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) + | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) + | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3) + | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2) + | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) + | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) + | Lassign(id, e) -> Lassign(id, subst e) + | Lsend (k, met, obj, args) -> + Lsend (k, subst met, subst obj, List.map subst args) + | Levent (lam, evt) -> Levent (subst lam, evt) + | Lifused (v, e) -> Lifused (v, subst e) + and subst_decl (id, exp) = (id, subst exp) + and subst_case (key, case) = (key, subst case) + in subst lam + + +(* To let-bind expressions to variables *) + +let bind str var exp body = + match exp with + Lvar var' when Ident.same var var' -> body + | _ -> Llet(str, var, exp, body) + +and commute_comparison = function +| Ceq -> Ceq| Cneq -> Cneq +| Clt -> Cgt | Cle -> Cge +| Cgt -> Clt | Cge -> Cle + +and negate_comparison = function +| Ceq -> Cneq| Cneq -> Ceq +| Clt -> Cge | Cle -> Cgt +| Cgt -> Cle | Cge -> Clt |