l4/pkg/ocaml/contrib/asmcomp/closure.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: closure.ml 8966 2008-08-01 12:52:14Z xleroy $ *)
  14
  15 (* Introduction of closures, uncurrying, recognition of direct calls *)
  16
  17 open Misc
  18 open Asttypes
  19 open Primitive
  20 open Lambda
  21 open Switch
  22 open Clambda
  23
  24 (* Auxiliaries for compiling functions *)
  25
  26 let rec split_list n l =
  27   if n <= 0 then ([], l) else begin
  28     match l with
  29       [] -> fatal_error "Closure.split_list"
  30     | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2)
  31   end
  32
  33 let rec build_closure_env env_param pos = function
  34     [] -> Tbl.empty
  35   | id :: rem ->
  36       Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none))
  37               (build_closure_env env_param (pos+1) rem)
  38
  39 (* Auxiliary for accessing globals.  We change the name of the global
  40    to the name of the corresponding asm symbol.  This is done here
  41    and no longer in Cmmgen so that approximations stored in .cmx files
  42    contain the right names if the -for-pack option is active. *)
  43
  44 let getglobal id =
  45   Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
  46         [], Debuginfo.none)
  47
  48 (* Check if a variable occurs in a [clambda] term. *)
  49
  50 let occurs_var var u =
  51   let rec occurs = function
  52       Uvar v -> v = var
  53     | Uconst cst -> false
  54     | Udirect_apply(lbl, args, _) -> List.exists occurs args
  55     | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
  56     | Uclosure(fundecls, clos) -> List.exists occurs clos
  57     | Uoffset(u, ofs) -> occurs u
  58     | Ulet(id, def, body) -> occurs def || occurs body
  59     | Uletrec(decls, body) ->
  60         List.exists (fun (id, u) -> occurs u) decls || occurs body
  61     | Uprim(p, args, _) -> List.exists occurs args
  62     | Uswitch(arg, s) ->
  63         occurs arg ||
  64         occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
  65     | Ustaticfail (_, args) -> List.exists occurs args
  66     | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
  67     | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr
  68     | Uifthenelse(cond, ifso, ifnot) ->
  69         occurs cond || occurs ifso || occurs ifnot
  70     | Usequence(u1, u2) -> occurs u1 || occurs u2
  71     | Uwhile(cond, body) -> occurs cond || occurs body
  72     | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
  73     | Uassign(id, u) -> id = var || occurs u
  74     | Usend(_, met, obj, args, _) ->
  75         occurs met || occurs obj || List.exists occurs args
  76   and occurs_array a =
  77     try
  78       for i = 0 to Array.length a - 1 do
  79         if occurs a.(i) then raise Exit
  80       done;
  81       false
  82     with Exit ->
  83       true
  84   in occurs u
  85
  86 (* Determine whether the estimated size of a clambda term is below
  87    some threshold *)
  88
  89 let prim_size prim args =
  90   match prim with
  91     Pidentity -> 0
  92   | Pgetglobal id -> 1
  93   | Psetglobal id -> 1
  94   | Pmakeblock(tag, mut) -> 5 + List.length args
  95   | Pfield f -> 1
  96   | Psetfield(f, isptr) -> if isptr then 4 else 1
  97   | Pfloatfield f -> 1
  98   | Psetfloatfield f -> 1
  99   | Pduprecord _ -> 10 + List.length args
 100   | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
 101   | Praise -> 4
 102   | Pstringlength -> 5
 103   | Pstringrefs | Pstringsets -> 6
 104   | Pmakearray kind -> 5 + List.length args
 105   | Parraylength kind -> if kind = Pgenarray then 6 else 2
 106   | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
 107   | Parraysetu kind -> if kind = Pgenarray then 16 else 4
 108   | Parrayrefs kind -> if kind = Pgenarray then 18 else 8
 109   | Parraysets kind -> if kind = Pgenarray then 22 else 10
 110   | Pbittest -> 3
 111   | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6
 112   | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6
 113   | _ -> 2 (* arithmetic and comparisons *)
 114
 115 (* Very raw approximation of switch cost *)
 116
 117 let lambda_smaller lam threshold =
 118   let size = ref 0 in
 119   let rec lambda_size lam =
 120     if !size > threshold then raise Exit;
 121     match lam with
 122       Uvar v -> ()
 123     | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
 124                         Const_int32 _ | Const_int64 _ | Const_nativeint _) |
 125              Const_pointer _) -> incr size
 126     | Uconst _ ->
 127         raise Exit (* avoid duplication of structured constants *)
 128     | Udirect_apply(fn, args, _) ->
 129         size := !size + 4; lambda_list_size args
 130     | Ugeneric_apply(fn, args, _) ->
 131         size := !size + 6; lambda_size fn; lambda_list_size args
 132     | Uclosure(defs, vars) ->
 133         raise Exit (* inlining would duplicate function definitions *)
 134     | Uoffset(lam, ofs) ->
 135         incr size; lambda_size lam
 136     | Ulet(id, lam, body) ->
 137         lambda_size lam; lambda_size body
 138     | Uletrec(bindings, body) ->
 139         raise Exit (* usually too large *)
 140     | Uprim(prim, args, _) ->
 141         size := !size + prim_size prim args;
 142         lambda_list_size args
 143     | Uswitch(lam, cases) ->
 144         if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;
 145         if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;
 146         lambda_size lam;
 147         lambda_array_size cases.us_actions_consts ;
 148         lambda_array_size cases.us_actions_blocks
 149     | Ustaticfail (_,args) -> lambda_list_size args
 150     | Ucatch(_, _, body, handler) ->
 151         incr size; lambda_size body; lambda_size handler
 152     | Utrywith(body, id, handler) ->
 153         size := !size + 8; lambda_size body; lambda_size handler
 154     | Uifthenelse(cond, ifso, ifnot) ->
 155         size := !size + 2;
 156         lambda_size cond; lambda_size ifso; lambda_size ifnot
 157     | Usequence(lam1, lam2) ->
 158         lambda_size lam1; lambda_size lam2
 159     | Uwhile(cond, body) ->
 160         size := !size + 2; lambda_size cond; lambda_size body
 161     | Ufor(id, low, high, dir, body) ->
 162         size := !size + 4; lambda_size low; lambda_size high; lambda_size body
 163     | Uassign(id, lam) ->
 164         incr size;  lambda_size lam
 165     | Usend(_, met, obj, args, _) ->
 166         size := !size + 8;
 167         lambda_size met; lambda_size obj; lambda_list_size args
 168   and lambda_list_size l = List.iter lambda_size l
 169   and lambda_array_size a = Array.iter lambda_size a in
 170   try
 171     lambda_size lam; !size <= threshold
 172   with Exit ->
 173     false
 174
 175 (* Check if a clambda term is ``pure'',
 176    that is without side-effects *and* not containing function definitions *)
 177
 178 let rec is_pure_clambda = function
 179     Uvar v -> true
 180   | Uconst cst -> true
 181   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
 182            Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
 183            Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
 184   | Uprim(p, args, _) -> List.for_all is_pure_clambda args
 185   | _ -> false
 186
 187 (* Simplify primitive operations on integers *)
 188
 189 let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n)
 190 let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n)
 191 let make_const_bool b = make_const_ptr(if b then 1 else 0)
 192
 193 let simplif_prim_pure p (args, approxs) dbg =
 194   match approxs with
 195     [Value_integer x] ->
 196       begin match p with
 197         Pidentity -> make_const_int x
 198       | Pnegint -> make_const_int (-x)
 199       | Poffsetint y -> make_const_int (x + y)
 200       | _ -> (Uprim(p, args, dbg), Value_unknown)
 201       end
 202   | [Value_integer x; Value_integer y] ->
 203       begin match p with
 204         Paddint -> make_const_int(x + y)
 205       | Psubint -> make_const_int(x - y)
 206       | Pmulint -> make_const_int(x * y)
 207       | Pdivint when y <> 0 -> make_const_int(x / y)
 208       | Pmodint when y <> 0 -> make_const_int(x mod y)
 209       | Pandint -> make_const_int(x land y)
 210       | Porint -> make_const_int(x lor y)
 211       | Pxorint -> make_const_int(x lxor y)
 212       | Plslint -> make_const_int(x lsl y)
 213       | Plsrint -> make_const_int(x lsr y)
 214       | Pasrint -> make_const_int(x asr y)
 215       | Pintcomp cmp ->
 216           let result = match cmp with
 217               Ceq -> x = y
 218             | Cneq -> x <> y
 219             | Clt -> x < y
 220             | Cgt -> x > y
 221             | Cle -> x <= y
 222             | Cge -> x >= y in
 223           make_const_bool result
 224       | _ -> (Uprim(p, args, dbg), Value_unknown)
 225       end
 226   | [Value_constptr x] ->
 227       begin match p with
 228         Pidentity -> make_const_ptr x
 229       | Pnot -> make_const_bool(x = 0)
 230       | Pisint -> make_const_bool true
 231       | _ -> (Uprim(p, args, dbg), Value_unknown)
 232       end
 233   | [Value_constptr x; Value_constptr y] ->
 234       begin match p with
 235         Psequand -> make_const_bool(x <> 0 && y <> 0)
 236       | Psequor  -> make_const_bool(x <> 0 || y <> 0)
 237       | _ -> (Uprim(p, args, dbg), Value_unknown)
 238       end
 239   | _ ->
 240       (Uprim(p, args, dbg), Value_unknown)
 241
 242 let simplif_prim p (args, approxs as args_approxs) dbg =
 243   if List.for_all is_pure_clambda args
 244   then simplif_prim_pure p args_approxs dbg
 245   else (Uprim(p, args, dbg), Value_unknown)
 246
 247 (* Substitute variables in a [ulambda] term (a body of an inlined function)
 248    and perform some more simplifications on integer primitives.
 249    Also perform alpha-conversion on let-bound identifiers to avoid
 250    clashes with locally-generated identifiers.
 251    The variables must not be assigned in the term.
 252    This is used to substitute "trivial" arguments for parameters
 253    during inline expansion, and also for the translation of let rec
 254    over functions. *)
 255
 256 let approx_ulam = function
 257     Uconst(Const_base(Const_int n)) -> Value_integer n
 258   | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c)
 259   | Uconst(Const_pointer n) -> Value_constptr n
 260   | _ -> Value_unknown
 261
 262 let rec substitute sb ulam =
 263   match ulam with
 264     Uvar v ->
 265       begin try Tbl.find v sb with Not_found -> ulam end
 266   | Uconst cst -> ulam
 267   | Udirect_apply(lbl, args, dbg) ->
 268       Udirect_apply(lbl, List.map (substitute sb) args, dbg)
 269   | Ugeneric_apply(fn, args, dbg) ->
 270       Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg)
 271   | Uclosure(defs, env) ->
 272       (* Question: should we rename function labels as well?  Otherwise,
 273          there is a risk that function labels are not globally unique.
 274          This should not happen in the current system because:
 275          - Inlined function bodies contain no Uclosure nodes
 276            (cf. function [lambda_smaller])
 277          - When we substitute offsets for idents bound by let rec
 278            in [close], case [Lletrec], we discard the original
 279            let rec body and use only the substituted term. *)
 280       Uclosure(defs, List.map (substitute sb) env)
 281   | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs)
 282   | Ulet(id, u1, u2) ->
 283       let id' = Ident.rename id in
 284       Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2)
 285   | Uletrec(bindings, body) ->
 286       let bindings1 =
 287         List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
 288       let sb' =
 289         List.fold_right
 290           (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
 291           bindings1 sb in
 292       Uletrec(
 293         List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1,
 294         substitute sb' body)
 295   | Uprim(p, args, dbg) ->
 296       let sargs = List.map (substitute sb) args in
 297       let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in
 298       res
 299   | Uswitch(arg, sw) ->
 300       Uswitch(substitute sb arg,
 301               { sw with
 302                 us_actions_consts =
 303                   Array.map (substitute sb) sw.us_actions_consts;
 304                 us_actions_blocks =
 305                   Array.map (substitute sb) sw.us_actions_blocks;
 306                })
 307   | Ustaticfail (nfail, args) ->
 308       Ustaticfail (nfail, List.map (substitute sb) args)
 309   | Ucatch(nfail, ids, u1, u2) ->
 310       Ucatch(nfail, ids, substitute sb u1, substitute sb u2)
 311   | Utrywith(u1, id, u2) ->
 312       let id' = Ident.rename id in
 313       Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
 314   | Uifthenelse(u1, u2, u3) ->
 315       begin match substitute sb u1 with
 316         Uconst(Const_pointer n) ->
 317           if n <> 0 then substitute sb u2 else substitute sb u3
 318       | su1 ->
 319           Uifthenelse(su1, substitute sb u2, substitute sb u3)
 320       end
 321   | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2)
 322   | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2)
 323   | Ufor(id, u1, u2, dir, u3) ->
 324       let id' = Ident.rename id in
 325       Ufor(id', substitute sb u1, substitute sb u2, dir,
 326            substitute (Tbl.add id (Uvar id') sb) u3)
 327   | Uassign(id, u) ->
 328       let id' =
 329         try
 330           match Tbl.find id sb with Uvar i -> i | _ -> assert false
 331         with Not_found ->
 332           id in
 333       Uassign(id', substitute sb u)
 334   | Usend(k, u1, u2, ul, dbg) ->
 335       Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg)
 336
 337 (* Perform an inline expansion *)
 338
 339 let is_simple_argument = function
 340     Uvar _ -> true
 341   | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
 342                       Const_int32 _ | Const_int64 _ | Const_nativeint _)) ->
 343       true
 344   | Uconst(Const_pointer _) -> true
 345   | _ -> false
 346
 347 let no_effects = function
 348     Uclosure _ -> true
 349   | Uconst(Const_base(Const_string _)) -> true
 350   | u -> is_simple_argument u
 351
 352 let rec bind_params_rec subst params args body =
 353   match (params, args) with
 354     ([], []) -> substitute subst body
 355   | (p1 :: pl, a1 :: al) ->
 356       if is_simple_argument a1 then
 357         bind_params_rec (Tbl.add p1 a1 subst) pl al body
 358       else begin
 359         let p1' = Ident.rename p1 in
 360         let body' =
 361           bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in
 362         if occurs_var p1 body then Ulet(p1', a1, body')
 363         else if no_effects a1 then body'
 364         else Usequence(a1, body')
 365       end
 366   | (_, _) -> assert false
 367
 368 let bind_params params args body =
 369   (* Reverse parameters and arguments to preserve right-to-left
 370      evaluation order (PR#2910). *)
 371   bind_params_rec Tbl.empty (List.rev params) (List.rev args) body
 372
 373 (* Check if a lambda term is ``pure'',
 374    that is without side-effects *and* not containing function definitions *)
 375
 376 let rec is_pure = function
 377     Lvar v -> true
 378   | Lconst cst -> true
 379   | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
 380            Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
 381            Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
 382   | Lprim(p, args) -> List.for_all is_pure args
 383   | Levent(lam, ev) -> is_pure lam
 384   | _ -> false
 385
 386 (* Generate a direct application *)
 387
 388 let direct_apply fundesc funct ufunct uargs =
 389   let app_args =
 390     if fundesc.fun_closed then uargs else uargs @ [ufunct] in
 391   let app =
 392     match fundesc.fun_inline with
 393       None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
 394     | Some(params, body) -> bind_params params app_args body in
 395   (* If ufunct can contain side-effects or function definitions,
 396      we must make sure that it is evaluated exactly once.
 397      If the function is not closed, we evaluate ufunct as part of the
 398      arguments.
 399      If the function is closed, we force the evaluation of ufunct first. *)
 400   if not fundesc.fun_closed || is_pure funct
 401   then app
 402   else Usequence(ufunct, app)
 403
 404 (* Add [Value_integer] or [Value_constptr] info to the approximation
 405    of an application *)
 406
 407 let strengthen_approx appl approx =
 408   match approx_ulam appl with
 409     (Value_integer _ | Value_constptr _) as intapprox -> intapprox
 410   | _ -> approx
 411
 412 (* If a term has approximation Value_integer or Value_constptr and is pure,
 413    replace it by an integer constant *)
 414
 415 let check_constant_result lam ulam approx =
 416   match approx with
 417     Value_integer n when is_pure lam -> make_const_int n
 418   | Value_constptr n when is_pure lam -> make_const_ptr n
 419   | _ -> (ulam, approx)
 420
 421 (* Evaluate an expression with known value for its side effects only,
 422    or discard it if it's pure *)
 423
 424 let sequence_constant_expr lam ulam1 (ulam2, approx2 as res2) =
 425   if is_pure lam then res2 else (Usequence(ulam1, ulam2), approx2)
 426
 427 (* Maintain the approximation of the global structure being defined *)
 428
 429 let global_approx = ref([||] : value_approximation array)
 430
 431 (* Maintain the nesting depth for functions *)
 432
 433 let function_nesting_depth = ref 0
 434 let excessive_function_nesting_depth = 5
 435
 436 (* Decorate clambda term with debug information *)
 437
 438 let rec add_debug_info ev u =
 439   match ev.lev_kind with
 440   | Lev_after _ ->
 441       begin match u with
 442       | Udirect_apply(lbl, args, dinfo) ->
 443           Udirect_apply(lbl, args, Debuginfo.from_call ev)
 444       | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
 445                        args2, dinfo2) ->
 446           Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
 447                          args2, Debuginfo.from_call ev)
 448       | Ugeneric_apply(fn, args, dinfo) ->
 449           Ugeneric_apply(fn, args, Debuginfo.from_call ev)
 450       | Uprim(Praise, args, dinfo) ->
 451           Uprim(Praise, args, Debuginfo.from_call ev)
 452       | Uprim(p, args, dinfo) ->
 453           Uprim(p, args, Debuginfo.from_call ev)
 454       | Usend(kind, u1, u2, args, dinfo) ->
 455           Usend(kind, u1, u2, args, Debuginfo.from_call ev)
 456       | Usequence(u1, u2) ->
 457           Usequence(u1, add_debug_info ev u2)
 458       | _ -> u
 459       end
 460   | _ -> u
 461
 462 (* Uncurry an expression and explicitate closures.
 463    Also return the approximation of the expression.
 464    The approximation environment [fenv] maps idents to approximations.
 465    Idents not bound in [fenv] approximate to [Value_unknown].
 466    The closure environment [cenv] maps idents to [ulambda] terms.
 467    It is used to substitute environment accesses for free identifiers. *)
 468
 469 let close_approx_var fenv cenv id =
 470   let approx = try Tbl.find id fenv with Not_found -> Value_unknown in
 471   match approx with
 472     Value_integer n ->
 473       make_const_int n
 474   | Value_constptr n ->
 475       make_const_ptr n
 476   | approx ->
 477       let subst = try Tbl.find id cenv with Not_found -> Uvar id in
 478       (subst, approx)
 479
 480 let close_var fenv cenv id =
 481   let (ulam, app) = close_approx_var fenv cenv id in ulam
 482
 483 let rec close fenv cenv = function
 484     Lvar id ->
 485       close_approx_var fenv cenv id
 486   | Lconst cst ->
 487       begin match cst with
 488         Const_base(Const_int n) -> (Uconst cst, Value_integer n)
 489       | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c))
 490       | Const_pointer n -> (Uconst cst, Value_constptr n)
 491       | _ -> (Uconst cst, Value_unknown)
 492       end
 493   | Lfunction(kind, params, body) as funct ->
 494       close_one_function fenv cenv (Ident.create "fun") funct
 495   | Lapply(funct, args, loc) ->
 496       let nargs = List.length args in
 497       begin match (close fenv cenv funct, close_list fenv cenv args) with
 498         ((ufunct, Value_closure(fundesc, approx_res)),
 499          [Uprim(Pmakeblock(_, _), uargs, _)])
 500         when List.length uargs = - fundesc.fun_arity ->
 501           let app = direct_apply fundesc funct ufunct uargs in
 502           (app, strengthen_approx app approx_res)
 503       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
 504         when nargs = fundesc.fun_arity ->
 505           let app = direct_apply fundesc funct ufunct uargs in
 506           (app, strengthen_approx app approx_res)
 507       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
 508         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
 509           let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
 510           (Ugeneric_apply(direct_apply fundesc funct ufunct first_args,
 511                           rem_args, Debuginfo.none),
 512            Value_unknown)
 513       | ((ufunct, _), uargs) ->
 514           (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
 515       end
 516   | Lsend(kind, met, obj, args) ->
 517       let (umet, _) = close fenv cenv met in
 518       let (uobj, _) = close fenv cenv obj in
 519       (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
 520        Value_unknown)
 521   | Llet(str, id, lam, body) ->
 522       let (ulam, alam) = close_named fenv cenv id lam in
 523       begin match (str, alam) with
 524         (Variable, _) ->
 525           let (ubody, abody) = close fenv cenv body in
 526           (Ulet(id, ulam, ubody), abody)
 527       | (_, (Value_integer _ | Value_constptr _))
 528         when str = Alias || is_pure lam ->
 529           close (Tbl.add id alam fenv) cenv body
 530       | (_, _) ->
 531           let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
 532           (Ulet(id, ulam, ubody), abody)
 533       end
 534   | Lletrec(defs, body) ->
 535       if List.for_all
 536            (function (id, Lfunction(_, _, _)) -> true | _ -> false)
 537            defs
 538       then begin
 539         (* Simple case: only function definitions *)
 540         let (clos, infos) = close_functions fenv cenv defs in
 541         let clos_ident = Ident.create "clos" in
 542         let fenv_body =
 543           List.fold_right
 544             (fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
 545             infos fenv in
 546         let (ubody, approx) = close fenv_body cenv body in
 547         let sb =
 548           List.fold_right
 549             (fun (id, pos, approx) sb ->
 550               Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
 551             infos Tbl.empty in
 552         (Ulet(clos_ident, clos, substitute sb ubody),
 553          approx)
 554       end else begin
 555         (* General case: recursive definition of values *)
 556         let rec clos_defs = function
 557           [] -> ([], fenv)
 558         | (id, lam) :: rem ->
 559             let (udefs, fenv_body) = clos_defs rem in
 560             let (ulam, approx) = close fenv cenv lam in
 561             ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in
 562         let (udefs, fenv_body) = clos_defs defs in
 563         let (ubody, approx) = close fenv_body cenv body in
 564         (Uletrec(udefs, ubody), approx)
 565       end
 566   | Lprim(Pgetglobal id, []) as lam ->
 567       check_constant_result lam
 568                             (getglobal id)
 569                             (Compilenv.global_approx id)
 570   | Lprim(Pmakeblock(tag, mut) as prim, lams) ->
 571       let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in
 572       (Uprim(prim, ulams, Debuginfo.none),
 573        begin match mut with
 574            Immutable -> Value_tuple(Array.of_list approxs)
 575          | Mutable -> Value_unknown
 576        end)
 577   | Lprim(Pfield n, [lam]) ->
 578       let (ulam, approx) = close fenv cenv lam in
 579       let fieldapprox =
 580         match approx with
 581           Value_tuple a when n < Array.length a -> a.(n)
 582         | _ -> Value_unknown in
 583       check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox
 584   | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
 585       let (ulam, approx) = close fenv cenv lam in
 586       (!global_approx).(n) <- approx;
 587       (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none),
 588        Value_unknown)
 589   | Lprim(Praise, [Levent(arg, ev)]) ->
 590       let (ulam, approx) = close fenv cenv arg in
 591       (Uprim(Praise, [ulam], Debuginfo.from_raise ev),
 592        Value_unknown)
 593   | Lprim(p, args) ->
 594       simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none
 595   | Lswitch(arg, sw) ->
 596 (* NB: failaction might get copied, thus it should be some Lstaticraise *)
 597       let (uarg, _) = close fenv cenv arg in
 598       let const_index, const_actions =
 599         close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction
 600       and block_index, block_actions =
 601         close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in
 602       (Uswitch(uarg,
 603                {us_index_consts = const_index;
 604                 us_actions_consts = const_actions;
 605                 us_index_blocks = block_index;
 606                 us_actions_blocks = block_actions}),
 607        Value_unknown)
 608   | Lstaticraise (i, args) ->
 609       (Ustaticfail (i, close_list fenv cenv args), Value_unknown)
 610   | Lstaticcatch(body, (i, vars), handler) ->
 611       let (ubody, _) = close fenv cenv body in
 612       let (uhandler, _) = close fenv cenv handler in
 613       (Ucatch(i, vars, ubody, uhandler), Value_unknown)
 614   | Ltrywith(body, id, handler) ->
 615       let (ubody, _) = close fenv cenv body in
 616       let (uhandler, _) = close fenv cenv handler in
 617       (Utrywith(ubody, id, uhandler), Value_unknown)
 618   | Lifthenelse(arg, ifso, ifnot) ->
 619       begin match close fenv cenv arg with
 620         (uarg, Value_constptr n) ->
 621           sequence_constant_expr arg uarg
 622             (close fenv cenv (if n = 0 then ifnot else ifso))
 623       | (uarg, _ ) ->
 624           let (uifso, _) = close fenv cenv ifso in
 625           let (uifnot, _) = close fenv cenv ifnot in
 626           (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
 627       end
 628   | Lsequence(lam1, lam2) ->
 629       let (ulam1, _) = close fenv cenv lam1 in
 630       let (ulam2, approx) = close fenv cenv lam2 in
 631       (Usequence(ulam1, ulam2), approx)
 632   | Lwhile(cond, body) ->
 633       let (ucond, _) = close fenv cenv cond in
 634       let (ubody, _) = close fenv cenv body in
 635       (Uwhile(ucond, ubody), Value_unknown)
 636   | Lfor(id, lo, hi, dir, body) ->
 637       let (ulo, _) = close fenv cenv lo in
 638       let (uhi, _) = close fenv cenv hi in
 639       let (ubody, _) = close fenv cenv body in
 640       (Ufor(id, ulo, uhi, dir, ubody), Value_unknown)
 641   | Lassign(id, lam) ->
 642       let (ulam, _) = close fenv cenv lam in
 643       (Uassign(id, ulam), Value_unknown)
 644   | Levent(lam, ev) ->
 645       let (ulam, approx) = close fenv cenv lam in
 646       (add_debug_info ev ulam, approx)
 647   | Lifused _ ->
 648       assert false
 649
 650 and close_list fenv cenv = function
 651     [] -> []
 652   | lam :: rem ->
 653       let (ulam, _) = close fenv cenv lam in
 654       ulam :: close_list fenv cenv rem
 655
 656 and close_list_approx fenv cenv = function
 657     [] -> ([], [])
 658   | lam :: rem ->
 659       let (ulam, approx) = close fenv cenv lam in
 660       let (ulams, approxs) = close_list_approx fenv cenv rem in
 661       (ulam :: ulams, approx :: approxs)
 662
 663 and close_named fenv cenv id = function
 664     Lfunction(kind, params, body) as funct ->
 665       close_one_function fenv cenv id funct
 666   | lam ->
 667       close fenv cenv lam
 668
 669 (* Build a shared closure for a set of mutually recursive functions *)
 670
 671 and close_functions fenv cenv fun_defs =
 672   (* Update and check nesting depth *)
 673   incr function_nesting_depth;
 674   let initially_closed =
 675     !function_nesting_depth < excessive_function_nesting_depth in
 676   (* Determine the free variables of the functions *)
 677   let fv =
 678     IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
 679   (* Build the function descriptors for the functions.
 680      Initially all functions are assumed not to need their environment
 681      parameter. *)
 682   let uncurried_defs =
 683     List.map
 684       (function
 685           (id, Lfunction(kind, params, body)) ->
 686             let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
 687             let arity = List.length params in
 688             let fundesc =
 689               {fun_label = label;
 690                fun_arity = (if kind = Tupled then -arity else arity);
 691                fun_closed = initially_closed;
 692                fun_inline = None } in
 693             (id, params, body, fundesc)
 694         | (_, _) -> fatal_error "Closure.close_functions")
 695       fun_defs in
 696   (* Build an approximate fenv for compiling the functions *)
 697   let fenv_rec =
 698     List.fold_right
 699       (fun (id, params, body, fundesc) fenv ->
 700         Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
 701       uncurried_defs fenv in
 702   (* Determine the offsets of each function's closure in the shared block *)
 703   let env_pos = ref (-1) in
 704   let clos_offsets =
 705     List.map
 706       (fun (id, params, body, fundesc) ->
 707         let pos = !env_pos + 1 in
 708         env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
 709         pos)
 710       uncurried_defs in
 711   let fv_pos = !env_pos in
 712   (* This reference will be set to false if the hypothesis that a function
 713      does not use its environment parameter is invalidated. *)
 714   let useless_env = ref initially_closed in
 715   (* Translate each function definition *)
 716   let clos_fundef (id, params, body, fundesc) env_pos =
 717     let env_param = Ident.create "env" in
 718     let cenv_fv =
 719       build_closure_env env_param (fv_pos - env_pos) fv in
 720     let cenv_body =
 721       List.fold_right2
 722         (fun (id, params, arity, body) pos env ->
 723           Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
 724         uncurried_defs clos_offsets cenv_fv in
 725     let (ubody, approx) = close fenv_rec cenv_body body in
 726     if !useless_env && occurs_var env_param ubody then useless_env := false;
 727     let fun_params = if !useless_env then params else params @ [env_param] in
 728     ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody),
 729      (id, env_pos, Value_closure(fundesc, approx))) in
 730   (* Translate all function definitions. *)
 731   let clos_info_list =
 732     if initially_closed then begin
 733       let cl = List.map2 clos_fundef uncurried_defs clos_offsets in
 734       (* If the hypothesis that the environment parameters are useless has been
 735          invalidated, then set [fun_closed] to false in all descriptions and
 736          recompile *)
 737       if !useless_env then cl else begin
 738         List.iter
 739           (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false)
 740           uncurried_defs;
 741         List.map2 clos_fundef uncurried_defs clos_offsets
 742       end
 743     end else
 744       (* Excessive closure nesting: assume environment parameter is used *)
 745         List.map2 clos_fundef uncurried_defs clos_offsets
 746     in
 747   (* Update nesting depth *)
 748   decr function_nesting_depth;
 749   (* Return the Uclosure node and the list of all identifiers defined,
 750      with offsets and approximations. *)
 751   let (clos, infos) = List.split clos_info_list in
 752   (Uclosure(clos, List.map (close_var fenv cenv) fv), infos)
 753
 754 (* Same, for one non-recursive function *)
 755
 756 and close_one_function fenv cenv id funct =
 757   match close_functions fenv cenv [id, funct] with
 758       ((Uclosure([_, _, params, body], _) as clos),
 759        [_, _, (Value_closure(fundesc, _) as approx)]) ->
 760         (* See if the function can be inlined *)
 761         if lambda_smaller body (!Clflags.inline_threshold + List.length params)
 762         then fundesc.fun_inline <- Some(params, body);
 763         (clos, approx)
 764     | _ -> fatal_error "Closure.close_one_function"
 765
 766 (* Close a switch *)
 767
 768 and close_switch fenv cenv cases num_keys default =
 769   let index = Array.create num_keys 0
 770   and store = mk_store Lambda.same in
 771
 772   (* First default case *)
 773   begin match default with
 774   | Some def when List.length cases < num_keys ->
 775       ignore (store.act_store def)
 776   | _ -> ()
 777   end ;
 778   (* Then all other cases *)
 779   List.iter
 780     (fun (key,lam) ->
 781      index.(key) <- store.act_store lam)
 782     cases ;
 783   (* Compile action *)
 784   let actions =
 785     Array.map
 786       (fun lam ->
 787         let ulam,_ = close fenv cenv lam in
 788         ulam)
 789       (store.act_get ()) in
 790   match actions with
 791   | [| |] -> [| |], [| |] (* May happen when default is None *)
 792   | _     -> index, actions
 793
 794
 795 (* The entry point *)
 796
 797 let intro size lam =
 798   function_nesting_depth := 0;
 799   global_approx := Array.create size Value_unknown;
 800   Compilenv.set_global_approx(Value_tuple !global_approx);
 801   let (ulam, approx) = close Tbl.empty Tbl.empty lam in
 802   global_approx := [||];
 803   ulam