mcc-0.5.4rta03/front/aml/ir/aml_ir_partial.ml

   1 (*
   2  * Partial-application elimination.
   3  *
   4  * The input to this stage is an IR program where the function arities
   5  * are completely uncorrelated.  For example, ((int, int, int) -> int) =
   6  * ((int) -> ((int) -> ((int) -> int))).  What we want is a program
   7  * where function arities are exact: if a function type has n arguments,
   8  * the value of that type is a real function expecting exactly n
   9  * arguments.
  10  *
  11  * To do this, we basically punt, and each escaping function is
  12  * curried: it takes one argument at a time.  We convert all the types
  13  * in the program so that higher-order function types are curried;
  14  * we convert applications so that they apply the right number of
  15  * arguments; and we build curry functions to convert normal
  16  * functions into curried ones.
  17  *
  18  * Note, we could be smarter than this.  One method would be to
  19  * look at the function body and see how functions are applied.
  20  * However, this gets harder to do when we import some of the
  21  * functions.  All of those will have to be curried anyway.
  22  *
  23  * ----------------------------------------------------------------
  24  *
  25  * @begin[license]
  26  * Copyright (C) 2002 Jason Hickey, Caltech
  27  *
  28  * This program is free software; you can redistribute it and/or
  29  * modify it under the terms of the GNU General Public License
  30  * as published by the Free Software Foundation; either version 2
  31  * of the License, or (at your option) any later version.
  32  *
  33  * This program is distributed in the hope that it will be useful,
  34  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  35  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36  * GNU General Public License for more details.
  37  *
  38  * You should have received a copy of the GNU General Public License
  39  * along with this program; if not, write to the Free Software
  40  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  41  *
  42  * Author: Jason Hickey
  43  * @email{jyh@cs.caltech.edu}
  44  * @end[license]
  45  *)
  46 open Symbol
  47 open Location
  48 open Field_table
  49
  50 open Aml_ir
  51 open Aml_ir_ds
  52 open Aml_ir_pos
  53 open Aml_ir_exn
  54 open Aml_ir_env
  55 open Aml_ir_type
  56
  57 module Pos = MakePos (struct let name = "Aml_ir_partial" end)
  58 open Pos
  59
  60 (************************************************************************
  61  * ENVIRONMENT
  62  ************************************************************************)
  63
  64 (*
  65  * The environment keeps track of the names of the curried functions.
  66  *)
  67 type cenv = var SymbolTable.t
  68
  69 (*
  70  * Empty environment.
  71  *)
  72 let cenv_empty = SymbolTable.empty
  73
  74 (*
  75  * Lookup a curry function based on its index.
  76  *)
  77 let cenv_add_fun = SymbolTable.add
  78
  79 (*
  80  * Test for membership.
  81  *)
  82 let cenv_mem_fun = SymbolTable.mem
  83
  84 (*
  85  * Lookup a fun, don't trap Not_found.
  86  *)
  87 let cenv_lookup_fun = SymbolTable.find
  88
  89 (************************************************************************
  90  * TYPES
  91  ************************************************************************)
  92
  93 (*
  94  * Curry a type.
  95  *)
  96 let rec curry_type_esc ty =
  97    let pos = string_pos "curry_type_esc" (type_exp_pos ty) in
  98    let loc = loc_of_type ty in
  99       match dest_type_core ty with
 100          TyVoid
 101        | TyInt
 102        | TyChar
 103        | TyString
 104        | TyFloat
 105        | TyVar _
 106        | TyProject _ ->
 107             ty
 108
 109        | TyFun ([], ty) ->
 110             make_type loc (TyFun ([], curry_type_esc ty))
 111        | TyFun (ty_args, ty_res) ->
 112             curry_fun_type loc ty_args ty_res
 113
 114        | TyTuple tyl ->
 115             make_type loc (TyTuple (curry_types_esc tyl))
 116        | TyArray ty ->
 117             make_type loc (TyArray (curry_type_esc ty))
 118
 119        | TyAll (vars, ty) ->
 120             make_type loc (TyAll (vars, curry_type_esc ty))
 121        | TyExists (vars, ty) ->
 122             make_type loc (TyExists (vars, curry_type_esc ty))
 123
 124        | TyApply (ty_var, tyl) ->
 125             make_type loc (TyApply (ty_var, curry_types_esc tyl))
 126        | TyUnion (ty_var, tyl, s) ->
 127             make_type loc (TyUnion (ty_var, curry_types_esc tyl, s))
 128        | TyRecord (ty_var, tyl) ->
 129             make_type loc (TyRecord (ty_var, curry_types_esc tyl))
 130        | TyFrame (ty_var, tyl) ->
 131             make_type loc (TyFrame (ty_var, curry_types_esc tyl))
 132        | TyModule (ty_var, tyl) ->
 133             make_type loc (TyModule (ty_var, curry_types_esc tyl))
 134        | TyTag (ty_var, tyl) ->
 135             make_type loc (TyTag (ty_var, curry_types_esc tyl))
 136        | TyDTuple (ty_var, tyl_opt) ->
 137             make_type loc (TyDTuple (ty_var, curry_types_opt_esc tyl_opt))
 138
 139        | TyExternal (ty, s) ->
 140             make_type loc (TyExternal (curry_type_esc ty, s))
 141        | TyFormat (ty1, ty2, ty3) ->
 142             make_type loc (TyFormat (curry_type_esc ty1, curry_type_esc ty2, curry_type_esc ty3))
 143
 144 and curry_fun_type loc ty_args ty_res =
 145    let ty_res = curry_type_esc ty_res in
 146       List.fold_right (fun ty_arg ty_res ->
 147             make_type loc (TyFun ([curry_type_esc ty_arg], ty_res))) ty_args ty_res
 148
 149 and curry_types_esc tyl =
 150    List.map curry_type_esc tyl
 151
 152 and curry_types_opt_esc tyl_opt =
 153    match tyl_opt with
 154       Some tyl -> Some (curry_types_esc tyl)
 155     | None -> None
 156
 157 (*
 158  * For a non-escaping function, do not curry the outermost
 159  * function type.
 160  *)
 161 let rec curry_type ty =
 162    let loc = loc_of_type ty in
 163       match dest_type_core ty with
 164          TyAll (vars, ty) ->
 165             make_type loc (TyAll (vars, curry_type ty))
 166        | TyFun (ty_args, ty_res) ->
 167             make_type loc (TyFun (curry_types_esc ty_args, curry_type_esc ty_res))
 168        | TyExternal (ty, _) ->
 169             curry_type ty
 170        | _ ->
 171             curry_type_esc ty
 172
 173 let curry_types tyl =
 174    List.map curry_type tyl
 175
 176 (*
 177  * Curry a typedef.
 178  *)
 179 let curry_record_tydef fields =
 180    FieldTable.map (fun (mflag, ty) ->
 181          mflag, curry_type_esc ty) fields
 182
 183 let curry_union_tydef fields =
 184    FieldTable.map curry_types_esc fields
 185
 186 let curry_module_tydef names fields =
 187    let fields = SymbolTable.map curry_type_esc fields in
 188       names, fields
 189
 190 let curry_tydef tydef =
 191    let { tydef_inner = inner } = tydef in
 192    let loc = loc_of_tydef_inner inner in
 193    let inner =
 194       match dest_tydef_inner_core inner with
 195          TyDefLambda ty ->
 196             TyDefLambda (curry_type_esc ty)
 197        | TyDefUnion fields ->
 198             TyDefUnion (curry_union_tydef fields)
 199        | TyDefRecord fields ->
 200             TyDefRecord (curry_record_tydef fields)
 201        | TyDefFrame fields ->
 202             TyDefFrame (curry_record_tydef fields)
 203        | TyDefModule (names, fields) ->
 204             let names, fields = curry_module_tydef names fields in
 205                TyDefModule (names, fields)
 206        | TyDefDTuple ty_var ->
 207             TyDefDTuple ty_var
 208    in
 209       { tydef with tydef_inner = make_tydef_inner loc inner }
 210
 211 (************************************************************************
 212  * FUNCTION CURRYING
 213  ************************************************************************)
 214
 215 (*
 216  * Build a curry function.
 217  * This is what the function looks like for n=3:
 218  *
 219  * let f_curry3_1 arg1 =
 220  *    let f_curry3_2 arg2 =
 221  *       let f_curry3_3 arg3 =
 222  *          let v = f(arg1, arg2, arg3) in
 223  *             return v
 224  *       in
 225  *          return f_curry3_3
 226  *    in
 227  *       return f_curry3_2
 228  *)
 229 let build_curry_fun genv venv cenv pos loc f ty_vars ty_fun vars =
 230    let pos = string_pos "build_curry_fun" pos in
 231    let ty_args, ty_res = dest_fun_type genv pos ty_fun in
 232    let s = Symbol.to_string f in
 233    let f_curry = cenv_lookup_fun cenv f in
 234    let len1 = List.length ty_args in
 235    let len2 = List.length vars in
 236    let _ =
 237       if len1 <> len2 then
 238          raise (IRException (pos, TypeArityMismatch (ty_fun, len1, len2)))
 239    in
 240
 241    (* Build a curried function type *)
 242    let build_fun_type ty_args ty_res =
 243          List.fold_right (fun ty_arg ty_res ->
 244                make_type loc (TyFun ([ty_arg], ty_res))) ty_args ty_res
 245    in
 246
 247    (* Build the expression *)
 248    let rec build vars_list ty_args_list i =
 249          match vars_list, ty_args_list with
 250             v :: vars, ty_arg :: ty_args ->
 251                (* Build the function that takes the next argument *)
 252                let ty_fun = build_fun_type ty_args_list ty_res in
 253                let body = build vars ty_args (succ i) in
 254                let f_curry_var = new_symbol_string (Printf.sprintf "%s.curry%d" s i) in
 255                let f_atom = AtomVar f_curry_var in
 256                   make_exp loc (LetFuns ([f_curry_var, loc, FunGlobalClass, [], ty_fun, [v], body],
 257                   make_exp loc (Return f_atom)))
 258
 259           | [], [] ->
 260                (* The final block just applies the function *)
 261                let v = new_symbol_string "res" in
 262                let args = List.map (fun v -> AtomVar v) vars in
 263                let ty_fun = make_type loc (TyFun (ty_args, ty_res)) in
 264                   make_exp loc (LetApply (v, ty_res, AtomVar f, args,
 265                   make_exp loc (Return (AtomVar v))))
 266           | _ ->
 267                raise (Invalid_argument "Aml_ir_partial.build_curry_fun.build")
 268    in
 269    let ty_fun = build_fun_type ty_args ty_res in
 270       match vars, ty_args with
 271          v :: vars, ty_arg :: ty_args ->
 272             (* Build the function that takes the next argument *)
 273             let f_curry_var = cenv_lookup_fun cenv f in
 274             let body = build vars ty_args 2 in
 275                ((f_curry_var, loc, FunGlobalClass, ty_vars, ty_fun, [v], body) : fundef)
 276        | _ ->
 277             raise (Invalid_argument "Aml_ir_partial.build_curry_fun")
 278
 279 (************************************************************************
 280  * ATOMS
 281  ************************************************************************)
 282
 283 (*
 284  * This variable is about to escape.
 285  * If it is a function, use the curried version.
 286  *)
 287 let coerce_var_esc cenv v =
 288    try cenv_lookup_fun cenv v with
 289       Not_found ->
 290          v
 291
 292 (*
 293  * Check if an atom is escaped.
 294  *)
 295 let rec is_atom_esc cenv a =
 296    match a with
 297       AtomVar v ->
 298          cenv_mem_fun cenv v
 299     | AtomTyConstrain (a, _)
 300     | AtomTyApply (a, _, _)
 301     | AtomUnop (_, a) ->
 302          is_atom_esc cenv a
 303     | _ ->
 304          false
 305
 306 (*
 307  * Coerce an atom that is about to escape.
 308  * All we really care about are functions.
 309  *)
 310 let rec coerce_atom_esc cenv a =
 311    match a with
 312       AtomInt _
 313     | AtomChar _
 314     | AtomFloat _
 315     | AtomFrameLabel _
 316     | AtomRecordLabel _
 317     | AtomModuleLabel _ ->
 318          a
 319     | AtomVar v ->
 320          AtomVar (coerce_var_esc cenv v)
 321     | AtomNil ty ->
 322          AtomNil (curry_type_esc ty)
 323     | AtomTyConstrain (a, ty) ->
 324          AtomTyConstrain (coerce_atom_esc cenv a, curry_type_esc ty)
 325     | AtomTyApply (a, ty, tyl) ->
 326          AtomTyApply (coerce_atom_esc cenv a, curry_type_esc ty, curry_types_esc tyl)
 327     | AtomTyPack (v, ty, tyl) ->
 328          AtomTyPack (coerce_var_esc cenv v, curry_type_esc ty, curry_types_esc tyl)
 329     | AtomTyUnpack v ->
 330          AtomTyUnpack (coerce_var_esc cenv v)
 331     | AtomConst (ty, ty_var, const_var) ->
 332          AtomConst (curry_type_esc ty, ty_var, const_var)
 333     | AtomUnop (op, a) ->
 334          AtomUnop (op, coerce_atom_esc cenv a)
 335     | AtomBinop (op, a1, a2) ->
 336          AtomBinop (op, coerce_atom_esc cenv a1, coerce_atom_esc cenv a2)
 337
 338 let coerce_atom_esc_list cenv atoms =
 339    List.map (coerce_atom_esc cenv) atoms
 340
 341 (*
 342  * Coerce an atom this is not escaping.
 343  * Type arguments are always curried.
 344  *)
 345 let rec coerce_atom cenv a =
 346    match a with
 347       AtomInt _
 348     | AtomChar _
 349     | AtomFloat _
 350     | AtomFrameLabel _
 351     | AtomRecordLabel _
 352     | AtomModuleLabel _
 353     | AtomVar _
 354     | AtomTyUnpack _ ->
 355          a
 356     | AtomNil ty ->
 357          AtomNil (curry_type ty)
 358     | AtomTyConstrain (a, ty) ->
 359          AtomTyConstrain (coerce_atom cenv a, curry_type ty)
 360     | AtomTyApply (a, ty, tyl) ->
 361          AtomTyApply (coerce_atom cenv a, curry_type ty, curry_types_esc tyl)
 362     | AtomTyPack (v, ty, tyl) ->
 363          AtomTyPack (v, curry_type ty, curry_types_esc tyl)
 364     | AtomConst (ty, ty_var, const_var) ->
 365          AtomConst (curry_type_esc ty, ty_var, const_var)
 366     | AtomUnop (op, a) ->
 367          AtomUnop (op, coerce_atom_esc cenv a)
 368     | AtomBinop (op, a1, a2) ->
 369          AtomBinop (op, coerce_atom_esc cenv a1, coerce_atom_esc cenv a2)
 370
 371 let coerce_atom_opt cenv a_opt =
 372    match a_opt with
 373       Some a -> Some (coerce_atom cenv a)
 374     | None -> None
 375
 376 let coerce_atom_list cenv atoms =
 377    List.map (coerce_atom cenv) atoms
 378
 379 (************************************************************************
 380  * EXPRESSIONS
 381  ************************************************************************)
 382
 383 (*
 384  * Coerce an allocation.
 385  * All the vars in the block escape.
 386  *)
 387 let coerce_alloc_op cenv op =
 388    match op with
 389       AllocTuple (ty_vars, ty, args) ->
 390          AllocTuple (ty_vars, curry_type_esc ty, coerce_atom_esc_list cenv args)
 391     | AllocUnion (ty_vars, ty, ty_var, const_var, args) ->
 392          AllocUnion (ty_vars, curry_type_esc ty, ty_var, const_var, coerce_atom_esc_list cenv args)
 393     | AllocRecord (ty_vars, ty, ty_var, fields) ->
 394          let fields = List.map (fun (label, a) -> label, coerce_atom_esc cenv a) fields in
 395             AllocRecord (ty_vars, curry_type_esc ty, ty_var, fields)
 396     | AllocDTuple (ty, ty_var, tag_var, args) ->
 397          AllocDTuple (curry_type_esc ty, ty_var, tag_var, coerce_atom_esc_list cenv args)
 398     | AllocArray (ty, args) ->
 399          AllocArray (curry_type_esc ty, coerce_atom_esc_list cenv args)
 400     | AllocVArray (ty, a1, a2) ->
 401          AllocVArray (curry_type_esc ty, coerce_atom_esc cenv a1, coerce_atom_esc cenv a2)
 402     | AllocModule (ty, ty_var, fields) ->
 403          let fields = SymbolTable.map (coerce_atom_esc cenv) fields in
 404             AllocModule (curry_type_esc ty, ty_var, fields)
 405     | AllocFrame (ty, ty_var, tyl) ->
 406          AllocFrame (curry_type_esc ty, ty_var, curry_types_esc tyl)
 407
 408 (*
 409  * Now coerce an expression.
 410  *)
 411 let rec coerce_exp genv venv cenv e =
 412    let pos = string_pos "coerce_exp" (exp_pos e) in
 413    let loc = loc_of_exp e in
 414       match dest_exp_core e with
 415          LetAtom (v, ty, a, e) ->
 416             let e =
 417                if is_atom_esc cenv a then
 418                   (* Add the escaped version *)
 419                   let ty = curry_type_esc ty in
 420                   let a = coerce_atom_esc cenv a in
 421                   let v' = new_symbol_string (Symbol.to_string v ^ "_curry") in
 422                   let venv = venv_add_var venv v' ty in
 423                   let cenv = cenv_add_fun cenv v v' in
 424                   let e = coerce_exp genv venv cenv e in
 425                      make_exp loc (LetAtom (v', ty, a, e))
 426                else
 427                   coerce_exp genv venv cenv e
 428             in
 429             let ty = curry_type ty in
 430             let a = coerce_atom cenv a in
 431             let venv = venv_add_var venv v ty in
 432                make_exp loc (LetAtom (v, ty, a, e))
 433        | LetExt (v, ty1, s, ty2, ty_args, args, e) ->
 434             let ty1 = curry_type_esc ty1 in
 435             let ty2 = curry_type ty2 in
 436             let ty_args = curry_types_esc ty_args in
 437             let args = coerce_atom_esc_list cenv args in
 438             let venv = venv_add_var venv v ty1 in
 439             let e = coerce_exp genv venv cenv e in
 440                make_exp loc (LetExt (v, ty1, s, ty2, ty_args, args, e))
 441        | TailCall (a, args) ->
 442             let a = coerce_atom cenv a in
 443             let args = coerce_atom_list cenv args in
 444                make_exp loc (TailCall (a, args))
 445        | Match (a, cases) ->
 446             let a = coerce_atom cenv a in
 447             let cases = List.map (fun (s, e) -> s, coerce_exp genv venv cenv e) cases in
 448                make_exp loc (Match (a, cases))
 449        | MatchDTuple (a, cases) ->
 450             let a = coerce_atom cenv a in
 451             let cases = List.map (fun (a_opt, e) -> coerce_atom_opt cenv a_opt, coerce_exp genv venv cenv e) cases in
 452                make_exp loc (MatchDTuple (a, cases))
 453        | LetAlloc (v, op, e) ->
 454             let op = coerce_alloc_op cenv op in
 455             let venv = venv_add_var venv v (type_of_alloc_op op) in
 456             let e = coerce_exp genv venv cenv e in
 457                make_exp loc (LetAlloc (v, op, e))
 458        | SetSubscript (a1, a2, a3, ty, e) ->
 459             (* This value escapes *)
 460             let a1 = coerce_atom cenv a1 in
 461             let a2 = coerce_atom cenv a2 in
 462             let a3 = coerce_atom_esc cenv a3 in
 463             let ty = curry_type_esc ty in
 464             let e = coerce_exp genv venv cenv e in
 465                make_exp loc (SetSubscript (a1, a2, a3, ty, e))
 466        | LetSubscript (v, ty, a1, a2, e) ->
 467             (* This value escapes *)
 468             let ty = curry_type_esc ty in
 469             let a1 = coerce_atom cenv a1 in
 470             let a2 = coerce_atom cenv a2 in
 471             let venv = venv_add_var venv v ty in
 472             let e = coerce_exp genv venv cenv e in
 473                make_exp loc (LetSubscript (v, ty, a1, a2, e))
 474        | SetGlobal (v, ty, a, e) ->
 475             (* This value escapes *)
 476             let ty = curry_type_esc ty in
 477             let a = coerce_atom_esc cenv a in
 478             let e = coerce_exp genv venv cenv e in
 479                make_exp loc (SetGlobal (v, ty, a, e))
 480        | LetRec (fields, e) ->
 481             let fields = List.map (fun (v, e, ty) -> v, coerce_exp genv venv cenv e, curry_type ty) fields in
 482             let e = coerce_exp genv venv cenv e in
 483                make_exp loc (LetRec (fields, e))
 484        | LetFuns (funs, e) ->
 485             (* Add curried functions to the list *)
 486             coerce_funs_exp genv venv cenv pos loc funs e
 487        | LetApply (v, ty, a, args, e) ->
 488             (* Partial applications use the curried form *)
 489             coerce_apply_exp genv venv cenv pos loc v ty a args e
 490        | Return a ->
 491             (* This value escapes *)
 492             let a = coerce_atom_esc cenv a in
 493                make_exp loc (Return a)
 494        | Try (e1, v, e2) ->
 495             let e1 = coerce_exp genv venv cenv e1 in
 496             let e2 = coerce_exp genv venv cenv e2 in
 497                make_exp loc (Try (e1, v, e2))
 498        | Raise (a, ty) ->
 499             (* This value escapes *)
 500             let a = coerce_atom_esc cenv a in
 501             let ty = curry_type_esc ty in
 502                make_exp loc (Raise (a, ty))
 503        | LetClosure _ ->
 504             raise (IRException (pos, InternalError))
 505
 506 (*
 507  * For each global function, build a curried form
 508  * and add the name to the curry environment.
 509  *)
 510 and coerce_funs_exp genv venv cenv pos loc funs e =
 511    let pos = string_pos "coerce_funs_exp" pos in
 512
 513    (* Build the new cenv *)
 514    let cenv =
 515       List.fold_left (fun cenv (f, _, gflag, _, _, _, _) ->
 516             match gflag with
 517                FunGlobalClass
 518              | FunTopLevelClass
 519              | FunPartialClass ->
 520                   let f_curry = new_symbol_string (Symbol.to_string f ^ "_curry") in
 521                      cenv_add_fun cenv f f_curry
 522              | FunLocalClass
 523              | FunContClass ->
 524                   cenv) cenv funs
 525    in
 526
 527    (* Convert all the function types *)
 528    let funs =
 529       List.map (fun (f, loc, gflag, ty_vars, ty_fun, vars, e) ->
 530             let ty_fun = curry_type ty_fun in
 531                f, loc, gflag, ty_vars, ty_fun, vars, e) funs
 532    in
 533
 534    (* Add to the variable environment *)
 535    let venv =
 536       List.fold_left (fun venv (f, loc, _, ty_vars, ty, _, _) ->
 537             venv_add_var venv f (make_type loc (TyAll (ty_vars, ty)))) venv funs
 538    in
 539
 540    (* Convert all the funs *)
 541    let funs =
 542       List.map (fun (f, loc, gflag, ty_vars, ty_fun, vars, e) ->
 543             let e = coerce_exp genv venv cenv e in
 544                f, loc, gflag, ty_vars, ty_fun, vars, e) funs
 545    in
 546
 547    (* Add all the curried versions *)
 548    let cfuns =
 549       List.fold_left (fun cfuns (f, loc, gflag, ty_vars, ty_fun, vars, _) ->
 550             match gflag with
 551                FunGlobalClass
 552              | FunTopLevelClass
 553              | FunPartialClass ->
 554                   let fundef = build_curry_fun genv venv cenv pos loc f ty_vars ty_fun vars in
 555                      fundef :: cfuns
 556              | FunLocalClass
 557              | FunContClass ->
 558                   cfuns) [] funs
 559    in
 560
 561    (* Convert the body *)
 562    let e = coerce_exp genv venv cenv e in
 563    let e =
 564       if cfuns <> [] then
 565          make_exp loc (LetFuns (cfuns, e))
 566       else
 567          e
 568    in
 569    let e = make_exp loc (LetFuns (funs, e)) in
 570       e
 571
 572 (*
 573  * Apply a function.  There are several cases to consider.
 574  *
 575  * If this is a partial application, use the curried function,
 576  * and apply one argument at a time.
 577  *
 578  * If this application has too many arguments, apply only as
 579  * many as the function will take.
 580  *)
 581 and coerce_apply_exp genv venv cenv pos loc v ty f args e =
 582    let pos = string_pos "coerce_apply_exp" pos in
 583    let ty = curry_type_esc ty in
 584    let venv = venv_add_var venv v ty in
 585    let e = coerce_exp genv venv cenv e in
 586
 587    (* All the arguments escape *)
 588    let args = coerce_atom_esc_list cenv args in
 589
 590    (* The function doesn't escape *)
 591    let f = coerce_atom cenv f in
 592
 593    (* See how many arguments the function wants *)
 594    let ty_fun = type_of_atom genv venv pos loc f in
 595    let ty_args, ty_res = dest_fun_type genv pos ty_fun in
 596    let len1 = List.length ty_args in
 597    let len2 = List.length args in
 598       if len1 = len2 then
 599          make_exp loc (LetApply (v, ty, f, args, e))
 600       else if len1 < len2 then
 601          coerce_apply_too_many genv venv cenv pos loc v ty f len1 ty_args ty_res args e
 602       else
 603          coerce_apply_partial genv venv cenv pos loc v ty f len1 ty_args ty_res args e
 604
 605 (*
 606  * We have too many arguments.
 607  * Apply as many as possible at once, then recurse.
 608  *)
 609 and coerce_apply_too_many genv venv cenv pos loc v ty f len ty_args ty_res args e =
 610    let pos = string_pos "coerce_apply_too_many" pos in
 611    let args1, args2 = Mc_list_util.split len args in
 612    let ty_args1, ty_args2 = Mc_list_util.split len ty_args in
 613    let ty_fun = make_type loc (TyFun (ty_args1, make_type loc (TyFun (ty_args2, ty_res)))) in
 614
 615    (* Get a name for the new function *)
 616    let f' = new_symbol_string "partial" in
 617    let venv = venv_add_var venv f' ty_fun in
 618
 619    (* Build the expression *)
 620    let e = coerce_apply_exp genv venv cenv pos loc v ty (AtomVar f') args2 e in
 621       make_exp loc (LetApply (f', ty_fun, f, args1, e))
 622
 623 (*
 624  * We have too few arguments.
 625  * Define v as a function that will take the rest of the
 626  * arguments and apply f to them.
 627  *)
 628 and coerce_apply_partial genv venv cenv pos loc v ty f len ty_args ty_res args1 e =
 629    let pos = string_pos "coerce_apply_partial" pos in
 630    let ty_args2 = Mc_list_util.nth_tl len ty_args in
 631    let vars2 = List.map (fun _ -> new_symbol_string "arg") ty_args2 in
 632    let args2 = List.map (fun v -> AtomVar v) vars2 in
 633
 634    (* Define v as a new function *)
 635    let body =
 636       make_exp loc (LetApply (v, ty_res, f, args1 @ args2,
 637       make_exp loc (Return (AtomVar v))))
 638    in
 639       make_exp loc (LetFuns ([v, loc, FunGlobalClass, [], ty, vars2, body], e))
 640
 641 (************************************************************************
 642  * CONVERT THE PROGRAM
 643  ************************************************************************)
 644
 645 (*
 646  * Initializer.
 647  *)
 648 let coerce_init cenv init =
 649    match init with
 650       InitString _ ->
 651          init
 652     | InitAtom a ->
 653          InitAtom (coerce_atom cenv a)
 654     | InitAlloc op ->
 655          InitAlloc (coerce_alloc_op cenv op)
 656
 657 (*
 658  * Convert partial applications in the program.
 659  *)
 660 let partial_prog prog =
 661    let { prog_types = types;
 662          prog_globals = globals;
 663          prog_tags = tags;
 664          prog_import = import;
 665          prog_export = export;
 666          prog_funs = funs
 667        } = prog
 668    in
 669
 670    (* Convert the outermost types *)
 671    let types = SymbolTable.map curry_tydef types in
 672    let globals =
 673       SymbolTable.map (fun (ty, init) ->
 674             curry_type_esc ty, init) globals
 675    in
 676    let tags =
 677       SymbolTable.map (fun (ty_var, tyl) ->
 678             ty_var, curry_types_esc tyl) tags
 679    in
 680    let import =
 681       SymbolTable.map (fun import ->
 682             { import with import_type = curry_type_esc import.import_type }) import
 683    in
 684    let export =
 685       SymbolTable.map (fun export ->
 686             { export with export_type = curry_type_esc export.export_type }) export
 687    in
 688    let funs =
 689       SymbolTable.map (fun (loc, gflag, ty_vars, ty, vars, e) ->
 690             loc, gflag, ty_vars, curry_type ty, vars, e) funs
 691    in
 692
 693    (* Rebuild the prog *)
 694    let prog =
 695       { prog with prog_types = types;
 696                   prog_globals = globals;
 697                   prog_tags = tags;
 698                   prog_import = import;
 699                   prog_export = export;
 700                   prog_funs = funs
 701       }
 702    in
 703
 704    (* Build environments *)
 705    let genv = genv_of_prog prog in
 706    let venv = venv_of_prog prog in
 707    let cenv = SymbolTable.empty in
 708
 709    (* Convert the function bodies *)
 710    let funs =
 711       SymbolTable.map (fun (loc, gflag, ty, ty_vars, vars, e) ->
 712             loc, gflag, ty, ty_vars, vars, coerce_exp genv venv cenv e) funs
 713    in
 714
 715    (* Now convert the parts *)
 716    let globals =
 717       SymbolTable.mapi (fun v (ty, init) ->
 718             let init = coerce_init cenv init in
 719                ty, init) globals
 720    in
 721
 722    (* Rebuild the prog *)
 723    let prog =
 724       { prog with prog_globals = globals;
 725                   prog_funs = funs
 726       }
 727    in
 728       prog
 729
 730 (*!
 731  * @docoff
 732  *
 733  * -*-
 734  * Local Variables:
 735  * Caml-master: "compile"
 736  * End:
 737  * -*-
 738  *)