path: root/bytecomp/translcore.ml

(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            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$ *)

(* Translation from typed abstract syntax to lambda terms,
   for the core language *)

open Misc
open Asttypes
open Primitive
open Path
open Types
open Typedtree
open Typeopt
open Lambda

type error =
    Illegal_letrec_pat
  | Illegal_letrec_expr
  | Free_super_var
  | Unknown_builtin_primitive of string

exception Error of Location.t * error

(* Forward declaration -- to be filled in by Translmod.transl_module *)
let transl_module =
  ref((fun cc rootpath modl -> assert false) :
      module_coercion -> Path.t option -> module_expr -> lambda)

let transl_object =
  ref (fun id s cl -> assert false :
       Ident.t -> string list -> class_expr -> lambda)

(* Translation of primitives *)

let comparisons_table = create_hashtable 11 [
  "%equal",
      (Pccall{prim_name = "caml_equal"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Ceq,
       Pfloatcomp Ceq,
       Pccall{prim_name = "caml_string_equal"; prim_arity = 2;
              prim_alloc = false;
              prim_native_name = ""; prim_native_float = false},
       Pbintcomp(Pnativeint, Ceq),
       Pbintcomp(Pint32, Ceq),
       Pbintcomp(Pint64, Ceq),
       true);
  "%notequal",
      (Pccall{prim_name = "caml_notequal"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Cneq,
       Pfloatcomp Cneq,
       Pccall{prim_name = "caml_string_notequal"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pbintcomp(Pnativeint, Cneq),
       Pbintcomp(Pint32, Cneq),
       Pbintcomp(Pint64, Cneq),
       true);
  "%lessthan",
      (Pccall{prim_name = "caml_lessthan"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Clt,
       Pfloatcomp Clt,
       Pccall{prim_name = "caml_string_lessthan"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pbintcomp(Pnativeint, Clt),
       Pbintcomp(Pint32, Clt),
       Pbintcomp(Pint64, Clt),
       false);
  "%greaterthan",
      (Pccall{prim_name = "caml_greaterthan"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Cgt,
       Pfloatcomp Cgt,
       Pccall{prim_name = "caml_string_greaterthan"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pbintcomp(Pnativeint, Cgt),
       Pbintcomp(Pint32, Cgt),
       Pbintcomp(Pint64, Cgt),
       false);
  "%lessequal",
      (Pccall{prim_name = "caml_lessequal"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Cle,
       Pfloatcomp Cle,
       Pccall{prim_name = "caml_string_lessequal"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pbintcomp(Pnativeint, Cle),
       Pbintcomp(Pint32, Cle),
       Pbintcomp(Pint64, Cle),
       false);
  "%greaterequal",
      (Pccall{prim_name = "caml_greaterequal"; prim_arity = 2;
              prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pintcomp Cge,
       Pfloatcomp Cge,
       Pccall{prim_name = "caml_string_greaterequal"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pbintcomp(Pnativeint, Cge),
       Pbintcomp(Pint32, Cge),
       Pbintcomp(Pint64, Cge),
       false);
  "%compare",
      (Pccall{prim_name = "caml_compare"; prim_arity = 2; prim_alloc = true;
              prim_native_name = ""; prim_native_float = false},
       Pccall{prim_name = "caml_int_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pccall{prim_name = "caml_float_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pccall{prim_name = "caml_string_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pccall{prim_name = "caml_nativeint_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pccall{prim_name = "caml_int32_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       Pccall{prim_name = "caml_int64_compare"; prim_arity = 2;
              prim_alloc = false; prim_native_name = "";
              prim_native_float = false},
       false)
]

let primitives_table = create_hashtable 57 [
  "%identity", Pidentity;
  "%ignore", Pignore;
  "%field0", Pfield 0;
  "%field1", Pfield 1;
  "%setfield0", Psetfield(0, true);
  "%makeblock", Pmakeblock(0, Immutable);
  "%makemutable", Pmakeblock(0, Mutable);
  "%raise", Praise;
  "%sequand", Psequand;
  "%sequor", Psequor;
  "%boolnot", Pnot;
  "%negint", Pnegint;
  "%succint", Poffsetint 1;
  "%predint", Poffsetint(-1);
  "%addint", Paddint;
  "%subint", Psubint;
  "%mulint", Pmulint;
  "%divint", Pdivint;
  "%modint", Pmodint;
  "%andint", Pandint;
  "%orint", Porint;
  "%xorint", Pxorint;
  "%lslint", Plslint;
  "%lsrint", Plsrint;
  "%asrint", Pasrint;
  "%eq", Pintcomp Ceq;
  "%noteq", Pintcomp Cneq;
  "%ltint", Pintcomp Clt;
  "%leint", Pintcomp Cle;
  "%gtint", Pintcomp Cgt;
  "%geint", Pintcomp Cge;
  "%incr", Poffsetref(1);
  "%decr", Poffsetref(-1);
  "%intoffloat", Pintoffloat;
  "%floatofint", Pfloatofint;
  "%negfloat", Pnegfloat;
  "%absfloat", Pabsfloat;
  "%addfloat", Paddfloat;
  "%subfloat", Psubfloat;
  "%mulfloat", Pmulfloat;
  "%divfloat", Pdivfloat;
  "%eqfloat", Pfloatcomp Ceq;
  "%noteqfloat", Pfloatcomp Cneq;
  "%ltfloat", Pfloatcomp Clt;
  "%lefloat", Pfloatcomp Cle;
  "%gtfloat", Pfloatcomp Cgt;
  "%gefloat", Pfloatcomp Cge;
  "%string_length", Pstringlength;
  "%string_safe_get", Pstringrefs;
  "%string_safe_set", Pstringsets;
  "%string_unsafe_get", Pstringrefu;
  "%string_unsafe_set", Pstringsetu;
  "%array_length", Parraylength Pgenarray;
  "%array_safe_get", Parrayrefs Pgenarray;
  "%array_safe_set", Parraysets Pgenarray;
  "%array_unsafe_get", Parrayrefu Pgenarray;
  "%array_unsafe_set", Parraysetu Pgenarray;
  "%obj_size", Parraylength Pgenarray;
  "%obj_field", Parrayrefu Pgenarray;
  "%obj_set_field", Parraysetu Pgenarray;
  "%obj_is_int", Pisint;
  "%lazy_force", Plazyforce;
  "%nativeint_of_int", Pbintofint Pnativeint;
  "%nativeint_to_int", Pintofbint Pnativeint;
  "%nativeint_neg", Pnegbint Pnativeint;
  "%nativeint_add", Paddbint Pnativeint;
  "%nativeint_sub", Psubbint Pnativeint;
  "%nativeint_mul", Pmulbint Pnativeint;
  "%nativeint_div", Pdivbint Pnativeint;
  "%nativeint_mod", Pmodbint Pnativeint;
  "%nativeint_and", Pandbint Pnativeint;
  "%nativeint_or",  Porbint Pnativeint;
  "%nativeint_xor", Pxorbint Pnativeint;
  "%nativeint_lsl", Plslbint Pnativeint;
  "%nativeint_lsr", Plsrbint Pnativeint;
  "%nativeint_asr", Pasrbint Pnativeint;
  "%int32_of_int", Pbintofint Pint32;
  "%int32_to_int", Pintofbint Pint32;
  "%int32_neg", Pnegbint Pint32;
  "%int32_add", Paddbint Pint32;
  "%int32_sub", Psubbint Pint32;
  "%int32_mul", Pmulbint Pint32;
  "%int32_div", Pdivbint Pint32;
  "%int32_mod", Pmodbint Pint32;
  "%int32_and", Pandbint Pint32;
  "%int32_or",  Porbint Pint32;
  "%int32_xor", Pxorbint Pint32;
  "%int32_lsl", Plslbint Pint32;
  "%int32_lsr", Plsrbint Pint32;
  "%int32_asr", Pasrbint Pint32;
  "%int64_of_int", Pbintofint Pint64;
  "%int64_to_int", Pintofbint Pint64;
  "%int64_neg", Pnegbint Pint64;
  "%int64_add", Paddbint Pint64;
  "%int64_sub", Psubbint Pint64;
  "%int64_mul", Pmulbint Pint64;
  "%int64_div", Pdivbint Pint64;
  "%int64_mod", Pmodbint Pint64;
  "%int64_and", Pandbint Pint64;
  "%int64_or",  Porbint Pint64;
  "%int64_xor", Pxorbint Pint64;
  "%int64_lsl", Plslbint Pint64;
  "%int64_lsr", Plsrbint Pint64;
  "%int64_asr", Pasrbint Pint64;
  "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint);
  "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32);
  "%int64_of_int32", Pcvtbint(Pint32, Pint64);
  "%int64_to_int32", Pcvtbint(Pint64, Pint32);
  "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64);
  "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint);
  "%caml_ba_ref_1",
    Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_ref_2",
    Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_ref_3",
    Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_1",
    Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_2",
    Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_set_3",
    Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_1",
    Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_2",
    Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_ref_3",
    Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_1",
    Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_2",
    Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout);
  "%caml_ba_unsafe_set_3",
    Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)
]

let prim_makearray =
  { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
    prim_native_name = ""; prim_native_float = false }

let prim_obj_dup =
  { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
    prim_native_name = ""; prim_native_float = false }

let transl_prim loc prim args =
  let prim_name = prim.prim_name in
  try
    let (gencomp, intcomp, floatcomp, stringcomp,
         nativeintcomp, int32comp, int64comp,
         simplify_constant_constructor) =
      Hashtbl.find comparisons_table prim_name in
    begin match args with
      [arg1; {exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}]
      when simplify_constant_constructor ->
        intcomp
    | [{exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}; arg2]
      when simplify_constant_constructor ->
        intcomp
    | [arg1; {exp_desc = Texp_variant(_, None)}]
      when simplify_constant_constructor ->
        intcomp
    | [{exp_desc = Texp_variant(_, None)}; exp2]
      when simplify_constant_constructor ->
        intcomp
    | [arg1; arg2] when has_base_type arg1 Predef.path_int
                     || has_base_type arg1 Predef.path_char ->
        intcomp
    | [arg1; arg2] when has_base_type arg1 Predef.path_float ->
        floatcomp
    | [arg1; arg2] when has_base_type arg1 Predef.path_string ->
        stringcomp
    | [arg1; arg2] when has_base_type arg1 Predef.path_nativeint ->
        nativeintcomp
    | [arg1; arg2] when has_base_type arg1 Predef.path_int32 ->
        int32comp
    | [arg1; arg2] when has_base_type arg1 Predef.path_int64 ->
        int64comp
    | _ ->
        gencomp
    end
  with Not_found ->
  try
    let p =
      match prim_name with
          "%revapply" -> Prevapply loc
        | "%apply" -> Pdirapply loc
        | name -> Hashtbl.find primitives_table name in
    (* Try strength reduction based on the type of the argument *)
    begin match (p, args) with
        (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
      | (Parraylength Pgenarray, [arg])   -> Parraylength(array_kind arg)
      | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1)
      | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1)
      | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1)
      | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1)
      | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
                      arg1 :: _) ->
            let (k, l) = bigarray_kind_and_layout arg1 in
            Pbigarrayref(unsafe, n, k, l)
      | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout),
                      arg1 :: _) ->
            let (k, l) = bigarray_kind_and_layout arg1 in
            Pbigarrayset(unsafe, n, k, l)
      | _ -> p
    end
  with Not_found ->
    if String.length prim_name > 0 && prim_name.[0] = '%' then
      raise(Error(loc, Unknown_builtin_primitive prim_name));
    Pccall prim

(*> JOCAML *)
(*
  Build a sequence if needed, this function is called to put sequence
  instead of '&' in some occasions.
  No debugging information is inserted
*)
let make_sequence lam1 lam2 =
  if lam1 = lambda_unit then
    lam2
  else if lam2 = lambda_unit then
    lam1
  else
    Lsequence (lam1, lam2)

(* 'simple' primitives cannot fail (ie never raise an exception) *)
let simple_prim p =
  let prim =
    try
      let (gencomp, _, _, _, _, _, _, _) =
        Hashtbl.find comparisons_table p.prim_name in
      gencomp
    with Not_found ->
      try
        Hashtbl.find primitives_table p.prim_name
      with Not_found ->
        Pccall p in
  not (may_raise prim)

let () = Transljoin.simple_prim := simple_prim

(*< JOCAML *)

(* Eta-expand a primitive without knowing the types of its arguments *)

let transl_primitive p =
  let prim =
    try
      let (gencomp, _, _, _, _, _, _, _) =
        Hashtbl.find comparisons_table p.prim_name in
      gencomp
    with Not_found ->
    try
      Hashtbl.find primitives_table p.prim_name
    with Not_found ->
      Pccall p in
  match prim with
    Plazyforce ->
      let parm = Ident.create "prim" in
      Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none)
  | _ ->
      let rec make_params n =
        if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
      let params = make_params p.prim_arity in
      Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))

(* To check the well-formedness of r.h.s. of "let rec" definitions *)

let check_recursive_lambda idlist lam =
  let rec check_top idlist = function
    | Lvar v -> not (List.mem v idlist)
    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
        true
    | Llet(str, id, arg, body) ->
        check idlist arg && check_top (add_let id arg idlist) body
    | Lletrec(bindings, body) ->
        let idlist' = add_letrec bindings idlist in
        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
        check_top idlist' body
    | Lprim (Pmakearray (Pgenarray), args) -> false
    | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
    | Levent (lam, _) -> check_top idlist lam
    | lam -> check idlist lam

  and check idlist = function
    | Lvar _ -> true
    | Lfunction(kind, params, body) -> true
    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
        true
    | Llet(str, id, arg, body) ->
        check idlist arg && check (add_let id arg idlist) body
    | Lletrec(bindings, body) ->
        let idlist' = add_letrec bindings idlist in
        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
        check idlist' body
    | Lprim(Pmakeblock(tag, mut), args) ->
        List.for_all (check idlist) args
    | Lprim(Pmakearray(_), args) ->
        List.for_all (check idlist) args
    | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
    | Levent (lam, _) -> check idlist lam
    | lam ->
        let fv = free_variables lam in
        not (List.exists (fun id -> IdentSet.mem id fv) idlist)

  and add_let id arg idlist =
    let fv = free_variables arg in
    if List.exists (fun id -> IdentSet.mem id fv) idlist
    then id :: idlist
    else idlist

  and add_letrec bindings idlist =
    List.fold_right (fun (id, arg) idl -> add_let id arg idl)
                    bindings idlist

  (* reverse-engineering the code generated by transl_record case 2 *)
  (* If you change this, you probably need to change Bytegen.size_of_lambda. *)
  and check_recursive_recordwith idlist = function
    | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) ->
       check_top idlist e1
       && check_recordwith_updates idlist id1 body
    | _ -> false

  and check_recordwith_updates idlist id1 = function
    | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont)
        -> id2 = id1 && check idlist e1
           && check_recordwith_updates idlist id1 cont
    | Lvar id2 -> id2 = id1
    | _ -> false

  in check_top idlist lam

(* To propagate structured constants *)

exception Not_constant

let extract_constant = function
    Lconst sc -> sc
  | _ -> raise Not_constant

let extract_float = function
    Const_base(Const_float f) -> f
  | _ -> fatal_error "Translcore.extract_float"

(* To find reasonable names for let-bound and lambda-bound idents *)

(*> JOCAML *)
let name_join_pattern default p = match p.pat_desc with
  | Tpat_var (id,_)   | Tpat_alias (_,id,_) -> id
  | _ -> Ident.create default
(*< JOCAML *)

let rec name_pattern default = function
    [] -> Ident.create default
  | (p, e) :: rem ->
      match p.pat_desc with
        Tpat_var (id, _) -> id
      | Tpat_alias(p, id, _) -> id
      | _ -> name_pattern default rem

(* Push the default values under the functional abstractions *)

let rec push_defaults loc bindings pat_expr_list partial =
  match pat_expr_list with
    [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] ->
      let pl = push_defaults exp.exp_loc bindings pl partial in
      [pat, {exp with exp_desc = Texp_function(l, pl, partial)}]
  | [pat, {exp_desc = Texp_let
             (Default, cases, ({exp_desc = Texp_function _} as e2))}] ->
      push_defaults loc (cases :: bindings) [pat, e2] partial
  | [pat, exp] ->
      let exp =
        List.fold_left
          (fun exp cases ->
            {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
          exp bindings
      in
      [pat, exp]
  | (pat, exp) :: _ when bindings <> [] ->
      let param = name_pattern "param" pat_expr_list in
      let name = Ident.name param in
      let exp =
        { exp with exp_loc = loc; exp_desc =
          Texp_match
            ({exp with exp_type = pat.pat_type; exp_desc =
              Texp_ident (Path.Pident param, mknoloc (Longident.Lident name),
                          {val_type = pat.pat_type; val_kind = Val_reg;
                           Types.val_loc = Location.none;
                          })},
             pat_expr_list, partial) }
      in
      push_defaults loc bindings
        [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total
  | _ ->
      pat_expr_list

(* Insertion of debugging events *)

let event_before exp lam = match lam with
| Lstaticraise (_,_) -> lam
| _ ->
  if !Clflags.debug
  then Levent(lam, {lev_loc = exp.exp_loc;
                    lev_kind = Lev_before;
                    lev_repr = None;
                    lev_env = Env.summary exp.exp_env})
  else lam

let event_after exp lam =
  if !Clflags.debug
  then Levent(lam, {lev_loc = exp.exp_loc;
                    lev_kind = Lev_after exp.exp_type;
                    lev_repr = None;
                    lev_env = Env.summary exp.exp_env})
  else lam

let event_function exp lam =
  if !Clflags.debug then
    let repr = Some (ref 0) in
    let (info, body) = lam repr in
    (info,
     Levent(body, {lev_loc = exp.exp_loc;
                   lev_kind = Lev_function;
                   lev_repr = repr;
                   lev_env = Env.summary exp.exp_env}))
  else
    lam None

let primitive_is_ccall = function
  (* Determine if a primitive is a Pccall or will be turned later into
     a C function call that may raise an exception *)
  | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ |
    Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ -> true
  | _ -> false

(* Assertions *)

let assert_failed exp =
  let (fname, line, char) =
    Location.get_pos_info exp.exp_loc.Location.loc_start in
  Lprim(Praise, [event_after exp
    (Lprim(Pmakeblock(0, Immutable),
          [transl_path Predef.path_assert_failure;
           Lconst(Const_block(0,
              [Const_base(Const_string fname);
               Const_base(Const_int line);
               Const_base(Const_int char)]))]))])
;;

(* do nothing to be used in place of Transljoin.reply_handler,
   when translation actual expressions (I mean non-processes) *)
let id_lam lam = lam
;;

let rec cut n l =
  if n = 0 then ([],l) else
  match l with [] -> failwith "Translcore.cut"
  | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)

(* Translation of expressions *)

let rec transl_exp e =
  let eval_once =
    (* Whether classes for immediate objects must be cached *)
    match e.exp_desc with
      Texp_function _ | Texp_for _ | Texp_while _ -> false
    | _ -> true
  in
  if eval_once then transl_exp0 e else
  Translobj.oo_wrap e.exp_env true transl_exp0 e

and transl_exp0 e =
  match e.exp_desc with
    Texp_ident(path, _, {val_kind = Val_prim p}) ->
      let public_send = p.prim_name = "%send" in
      if public_send || p.prim_name = "%sendself" then
        let kind = if public_send then Public else Self in
        let obj = Ident.create "obj" and meth = Ident.create "meth" in
        Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
      else if p.prim_name = "%sendcache" then
        let obj = Ident.create "obj" and meth = Ident.create "meth" in
        let cache = Ident.create "cache" and pos = Ident.create "pos" in
        Lfunction(Curried, [obj; meth; cache; pos],
                  Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
      else
        transl_primitive p
  | Texp_ident(path, _, {val_kind = Val_anc _}) ->
      raise(Error(e.exp_loc, Free_super_var))
  | Texp_ident
      (path, _,
       {val_kind = Val_reg|Val_self _|Val_channel (_,_)|Val_alone _}) ->
      transl_path path
  | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
  | Texp_constant cst ->
      Lconst(Const_base cst)
  | Texp_let(rec_flag, pat_expr_list, body) ->
      transl_let id_lam transl_exp
        rec_flag pat_expr_list (event_before body (transl_exp body))
(*> JOCAML *)
  | Texp_def (d,body) ->
      do_transl_def d (transl_exp body)
  | Texp_loc (d,body) -> assert false
(*>JOCAML*)
  | Texp_function (_, pat_expr_list, partial) ->
      let ((kind, params), body) =
        event_function e
          (function repr ->
            let pl = push_defaults e.exp_loc [] pat_expr_list partial in
            transl_function e.exp_loc !Clflags.native_code repr partial pl)
      in
      Lfunction(kind, params, body)
(* two small optimizations *)
  | Texp_apply
      ({exp_desc = Texp_ident(path, _, {val_kind = Val_alone id})},
       [_,Some arg,_])
      ->
        Lapply (Lvar id,[transl_exp arg],e.exp_loc)
  | Texp_apply
      ({exp_desc = Texp_ident(path, _, {val_kind = Val_channel (auto,idx)})},
       [_,Some arg,_])
      ->
        Transljoin.local_send_sync
	  auto idx (transl_exp arg)
	  e.exp_loc
(*<JOCAML*)
  | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs)
    when List.length oargs >= p.prim_arity
    && List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
      let args, args' = cut p.prim_arity oargs in
      let wrap f =
        if args' = []
        then event_after e f
        else event_after e (transl_apply f args' e.exp_loc)
      in
      let wrap0 f =
        if args' = [] then f else wrap f in
      let args = List.map (function _, Some x, _ -> x | _ -> assert false) args in
      let argl = transl_list transl_exp args in
      let public_send = p.prim_name = "%send"
        || not !Clflags.native_code && p.prim_name = "%sendcache"in
      if public_send || p.prim_name = "%sendself" then
        let kind = if public_send then Public else Self in
        let obj = List.hd argl in
        wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
      else if p.prim_name = "%sendcache" then
        match argl with [obj; meth; cache; pos] ->
          wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
        | _ -> assert false
      else begin
        let prim = transl_prim e.exp_loc p args in
        match (prim, args) with
          (Praise, [arg1]) ->
            wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
        | (_, _) ->
            begin match (prim, argl) with
            | (Plazyforce, [a]) ->
                wrap (Matching.inline_lazy_force a e.exp_loc)
            | (Plazyforce, _) -> assert false
            |_ -> let p = Lprim(prim, argl) in
               if primitive_is_ccall prim then wrap p else wrap0 p
            end
      end
  | Texp_apply(funct, oargs) ->
      event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
  | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
      Matching.for_multiple_match (id_lam,e.exp_loc)
        (transl_list transl_exp argl)
        (transl_cases transl_exp pat_expr_list) partial
  | Texp_match(arg, pat_expr_list, partial) ->
      Matching.for_function
        (id_lam,e.exp_loc) None
        (transl_exp arg)
        (transl_cases transl_exp pat_expr_list) partial
  | Texp_try(body, pat_expr_list) ->
      let id = name_pattern "exn" pat_expr_list in
      Ltrywith
        (transl_exp body, id,
         Matching.for_trywith
           (Lvar id)
           (transl_cases transl_exp pat_expr_list))
  | Texp_tuple el ->
      let ll = transl_list transl_exp el in
      begin try
        Lconst(Const_block(0, List.map extract_constant ll))
      with Not_constant ->
        Lprim(Pmakeblock(0, Immutable), ll)
      end
  | Texp_construct(_, _, cstr, args, _) ->
      let ll = transl_list transl_exp args in
      begin match cstr.cstr_tag with
        Cstr_constant n ->
          Lconst(Const_pointer n)
      | Cstr_block n ->
          begin try
            Lconst(Const_block(n, List.map extract_constant ll))
          with Not_constant ->
            Lprim(Pmakeblock(n, Immutable), ll)
          end
      | Cstr_exception (path, _) ->
          Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
      end
  | Texp_variant(l, arg) ->
      let tag = Btype.hash_variant l in
      begin match arg with
        None -> Lconst(Const_pointer tag)
      | Some arg ->
          let lam = transl_exp arg in
          try
            Lconst(Const_block(0, [Const_base(Const_int tag);
                                   extract_constant lam]))
          with Not_constant ->
            Lprim(Pmakeblock(0, Immutable),
                  [Lconst(Const_base(Const_int tag)); lam])
      end
  | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
      transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
  | Texp_record ([], _) ->
      fatal_error "Translcore.transl_exp: bad Texp_record"
  | Texp_field(arg, _, _, lbl) ->
      let access =
        match lbl.lbl_repres with
          Record_regular -> Pfield lbl.lbl_pos
        | Record_float -> Pfloatfield lbl.lbl_pos in
      Lprim(access, [transl_exp arg])
  | Texp_setfield(arg, _, _, lbl, newval) ->
      let access =
        match lbl.lbl_repres with
          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
        | Record_float -> Psetfloatfield lbl.lbl_pos in
      Lprim(access, [transl_exp arg; transl_exp newval])
  | Texp_array expr_list ->
      let kind = array_kind e in
      let ll = transl_list transl_exp expr_list in
      begin try
        (* Deactivate constant optimization if array is small enough *)
        if List.length ll <= 4 then raise Not_constant;
        let cl = List.map extract_constant ll in
        let master =
          match kind with
          | Paddrarray | Pintarray ->
              Lconst(Const_block(0, cl))
          | Pfloatarray ->
              Lconst(Const_float_array(List.map extract_float cl))
          | Pgenarray ->
              raise Not_constant in             (* can this really happen? *)
        Lprim(Pccall prim_obj_dup, [master])
      with Not_constant ->
        Lprim(Pmakearray kind, ll)
      end
  | Texp_ifthenelse(cond, ifso, Some ifnot) ->
      Lifthenelse(transl_exp cond,
                  event_before ifso (transl_exp ifso),
                  event_before ifnot (transl_exp ifnot))
  | Texp_ifthenelse(cond, ifso, None) ->
      Lifthenelse(transl_exp cond,
                  event_before ifso (transl_exp ifso),
                  lambda_unit)
  | Texp_sequence(expr1, expr2) ->
      Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
  | Texp_while(cond, body) ->
      Lwhile(transl_exp cond, event_before body (transl_exp body))
  | Texp_for(param, _, low, high, dir, body) ->
      Lfor(param, transl_exp low, transl_exp high, dir,
           event_before body (transl_exp body))
  | Texp_when(cond, body) ->
      event_before cond
        (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
                     staticfail))
  | Texp_send(_, _, Some exp) -> transl_exp exp
  | Texp_send(expr, met, None) ->
      let obj = transl_exp expr in
      let lam =
        match met with
          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
        | Tmeth_name nm ->
            let (tag, cache) = Translobj.meth obj nm in
            let kind = if cache = [] then Public else Cached in
            Lsend (kind, tag, obj, cache, e.exp_loc)
      in
      event_after e lam
  | Texp_new (cl, _, _) ->
      Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
  | Texp_instvar(path_self, path, _) ->
      Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
  | Texp_setinstvar(path_self, path, _, expr) ->
      transl_setinstvar (transl_path path_self) path expr
  | Texp_override(path_self, modifs) ->
      let cpy = Ident.create "copy" in
      Llet(Strict, cpy,
           Lapply(Translobj.oo_prim "copy", [transl_path path_self],
                  Location.none),
           List.fold_right
             (fun (path, _, expr) rem ->
                Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
             modifs
             (Lvar cpy))
  | Texp_letmodule(id, _, modl, body) ->
      Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
  | Texp_pack modl ->
      !transl_module Tcoerce_none None modl
  | Texp_assert (cond) ->
      if !Clflags.noassert
      then lambda_unit
      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e)
  | Texp_assertfalse -> assert_failed e
  | Texp_lazy e ->
      (* when e needs no computation (constants, identifiers, ...), we
         optimize the translation just as Lazy.lazy_from_val would
         do *)
      begin match e.exp_desc with
        (* a constant expr of type <> float gets compiled as itself *)
      | Texp_constant
          ( Const_int _ | Const_char _ | Const_string _
          | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
      | Texp_function(_, _, _)
      | Texp_construct (_, _, {cstr_arity = 0}, _, _)
        -> transl_exp e
      | Texp_constant(Const_float _) ->
          Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
      | Texp_ident(_, _, _) -> (* according to the type *)
          begin match e.exp_type.desc with
	  | Tproc _ -> assert false (* By typing *)
          (* the following may represent a float/forward/lazy: need a
             forward_tag *)
          | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
          | Tpoly(_,_) | Tfield(_,_,_,_) ->
              Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
          (* the following cannot be represented as float/forward/lazy:
             optimize *)
          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
          | Tvariant _
              -> transl_exp e
          (* optimize predefined types (excepted float) *)
          | Tconstr(_,_,_) ->
              if has_base_type e Predef.path_int
                || has_base_type e Predef.path_char
                || has_base_type e Predef.path_string
                || has_base_type e Predef.path_bool
                || has_base_type e Predef.path_unit
                || has_base_type e Predef.path_exn
                || has_base_type e Predef.path_array
                || has_base_type e Predef.path_list
                || has_base_type e Predef.path_format6
                || has_base_type e Predef.path_option
                || has_base_type e Predef.path_nativeint
                || has_base_type e Predef.path_int32
                || has_base_type e Predef.path_int64
              then transl_exp e
              else
                Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
          end
      (* other cases compile to a lazy block holding a function *)
      | _ ->
          let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
          Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])
      end
  | Texp_object (cs, meths) ->
      let cty = cs.cstr_type in
      let cl = Ident.create "class" in
      !transl_object cl meths
        { cl_desc = Tcl_structure cs;
          cl_loc = e.exp_loc;
          cl_type = Cty_signature cty;
          cl_env = e.exp_env }
(*> JOCAML *)
  | Texp_spawn (e) -> transl_spawn e
(*< JOCAML *)
  | _ ->
      Location.print_error Format.err_formatter e.exp_loc ;
      fatal_error "Translcore.transl_exp"

(*> JOCAML *)
(*
   - die is a boolean that indicates that produced code ends by
     the death of the current thread. As a consequence,
     the last asynchronous send need not fork a thread in case
     it fires a guarded process.

   - sync is None of asynchronous threads and Some id where id
   is the principal name
*)

and transl_proc die sync p = match p.exp_desc with
(* Mixed constructs *)
| Texp_let(rec_flag, pat_expr_list, body) ->
    transl_let
      (Transljoin.lambda_reply_handler sync p)
      (fun e -> Transljoin.reply_handler sync p transl_exp e)
      rec_flag pat_expr_list (transl_proc die sync body)
| Texp_def (d,body) ->
    do_transl_def d (transl_proc die sync body)
| Texp_loc (d,body) -> assert false
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
    Lifthenelse
      (Transljoin.reply_handler sync p transl_exp cond,
       transl_proc die sync ifso,
       transl_proc die sync ifnot)
| Texp_ifthenelse(cond, ifso, None) ->
    assert (sync = None) ; assert (Typejoin.get_replies p = []) ;    
    Lifthenelse (transl_exp cond, transl_proc die sync ifso, lambda_unit)
| Texp_sequence(e1, p2) ->
    make_sequence
      (Transljoin.reply_handler sync p transl_exp e1)
      (transl_proc die sync p2)
| Texp_when(cond, body) ->
    Lifthenelse
      (Transljoin.reply_handler sync p transl_exp cond,
       transl_proc die sync body, staticfail)
| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
    Matching.for_multiple_match
      (Transljoin.lambda_reply_handler sync p, p.exp_loc)
      (transl_list (Transljoin.reply_handler sync p transl_exp) argl)
      (transl_cases (transl_proc die sync) pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
    Matching.for_function
       (Transljoin.lambda_reply_handler sync p, p.exp_loc)
      None
      (Transljoin.reply_handler sync p transl_exp arg)
      (transl_cases (transl_proc die sync) pat_expr_list) partial
| Texp_for(param, _, low, high, dir, body) ->
    assert (sync = None) ;
    let lam_low = transl_exp low
    and lam_high = transl_exp high in
    Lfor(param, lam_low, lam_high, dir,
         event_before body (transl_spawn body))
(* Proc constructs *)
| Texp_par _ ->
  let psync, seqs, forks = Transljoin.as_procs sync p in
(* psync is some expression to compute as a result *)
      begin match psync with
      | None ->
          begin match forks, seqs with
          | [],[] ->  lambda_unit
          | fst::rem,_ ->
              transl_as_seq false seqs
                (List.fold_right
                   transl_fork
                   rem (transl_proc die None fst))
          | [],_ ->
              transl_as_seq die seqs lambda_unit
          end
      | Some psync ->
          transl_as_seq false seqs
            (List.fold_right transl_fork forks
               (transl_proc false sync psync))
      end
| Texp_asyncsend (_,_) | Texp_reply (_,_) | Texp_null  ->
    transl_simple_proc die sync p
| Texp_spawn _|Texp_object _|Texp_lazy _|Texp_assert _|
  Texp_letmodule  _|Texp_override _|Texp_setinstvar _|
  Texp_instvar _|Texp_new _|Texp_send _|
  Texp_while _|Texp_array _|
  Texp_setfield _|Texp_field _|Texp_record _|
  Texp_variant _|Texp_construct _|Texp_tuple _|Texp_try _|
  Texp_apply _|Texp_function _|Texp_constant _|Texp_ident _|
  Texp_assertfalse | Texp_pack _
  ->
    Location.print_error Format.err_formatter p.exp_loc ;
    fatal_error "Translcore.transl_proc"

(*
    Simple procs are defined as follows : the code for them does
   terminate and never fails,
   As a consequence, ``&'' can get translated to ``;''
*)
and transl_simple_proc die sync p = match p.exp_desc with
(* Mixed constructs *)
| Texp_let(rec_flag, pat_expr_list, body) ->
    transl_let
      id_lam
      transl_exp
      rec_flag pat_expr_list (transl_simple_proc die sync body)
| Texp_def (d,body) ->
    do_transl_def d (transl_simple_proc die sync body)
| Texp_loc (d,body) -> assert false
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
    Lifthenelse
      (transl_exp cond,
       transl_simple_proc die sync ifso,
       transl_simple_proc die sync ifnot)
| Texp_ifthenelse(cond, ifso, None) ->
    Lifthenelse (transl_exp cond,
                 transl_simple_proc die sync ifso,
                 lambda_unit)
| Texp_sequence(e, p) ->
    make_sequence (transl_exp e) (transl_simple_proc die sync p)
| Texp_when(cond, body) ->
      (Lifthenelse
         (transl_exp cond, transl_simple_proc die sync body, staticfail))
| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
    Matching.for_multiple_match (id_lam, p.exp_loc)
      (transl_list transl_exp argl)
      (transl_cases (transl_simple_proc die sync) pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
    Matching.for_function (id_lam, p.exp_loc) None
      (transl_exp arg)
      (transl_cases
         (transl_simple_proc die sync) pat_expr_list) partial
| Texp_for(param, _, low, high, dir, body) ->
    assert (sync=None) ;
    Lfor(param, transl_exp low, transl_exp high, dir,
         event_before body (transl_spawn body)) (* loop body should not fail *)
(* Proc constructs *)
| Texp_par (p1,p2) -> (* We can translate this ``&'' as a sequence *)
    make_sequence
      (transl_simple_proc false sync p1)
      (transl_simple_proc die sync p2)
| Texp_asyncsend
    ({exp_desc=Texp_ident (_,_,{val_kind=Val_channel (auto,num)})},e2) ->
      (if die then Transljoin.local_tail_send_async
      else Transljoin.local_send_async)
        auto num (transl_exp e2) p.exp_loc
| Texp_asyncsend
    ({exp_desc=Texp_ident (_,_,{val_kind=Val_alone (guard)})},e2) ->
      (if die then Transljoin.local_tail_send_alone
      else Transljoin.local_send_alone)
        guard (transl_exp e2) p.exp_loc
| Texp_asyncsend (e1,e2) ->
    (if die then Transljoin.tail_send_async else Transljoin.send_async)
      (transl_exp e1) (transl_exp e2) p.exp_loc
| Texp_reply (e, id) ->
    begin match sync with
    | Some main_id when main_id = id -> transl_exp e
    | _ ->
        Transljoin.reply_to
          (Transljoin.reply_handler sync p transl_exp e)
          (transl_path (Pident id)) p.exp_loc
    end
| Texp_null -> lambda_unit
(* Plain expression are errors *)
| Texp_spawn _|Texp_object _|Texp_lazy _|Texp_assert _|
  Texp_letmodule _|Texp_override _|Texp_setinstvar _|
  Texp_instvar _|Texp_new _|Texp_send _|
  Texp_while _|Texp_array _|
  Texp_setfield _|Texp_field _|Texp_record _|
  Texp_variant _|Texp_construct _|Texp_tuple _|Texp_try _|
  Texp_apply _|Texp_function _|Texp_constant _|Texp_ident _|
  Texp_assertfalse|Texp_pack _
 -> assert false

(* Parameter list for a guarded process *)

and transl_reaction (name,_) (Reac reac) =
  let (x, _ , actuals, idpats, p) = reac in
(* Principal continuation, as computed by typing *)
  let sync = Transljoin.principal p in
(* Important: argument order comes from actual pattern order,
   as Transljoin.create_table assumes *)
  let jpats =
    List.map
      (fun pats -> match pats with
      | p::_ -> p | [] -> assert false)
      actuals in
  let konts = List.map (fun jp -> !(jp.jpat_kont)) jpats in
  let body =
    List.fold_right
      (fun (param, pat) lam ->
        Matching.for_function
          (id_lam, Location.none) None (Lvar param) [pat,lam] Total)
      idpats
      (transl_proc true sync p) in
  let params =
    try
      List.fold_right2
        (fun k (id,_) r ->
          match k, sync with
          | Some kid, Some sync_id when not (Ident.equal kid sync_id) ->
              kid::id::r
          | Some kid,None ->
              kid::id::r
          | _,_ -> id::r)
        konts idpats [Ident.create "_x"]
    with
    | Invalid_argument _ ->
        Printf.eprintf "konts=%i, idpats=%i\n"
          (List.length konts) (List.length idpats) ;
        [Ident.create "_x"] in
  let lam = Lfunction (Curried, params, body) in
  x, sync, lam

and transl_dispatcher disp = 
  let Disp (d_id, chan, cls, partial) = disp in
  let z = Ident.create "#z#" in
  let rhs chan =
    if chan.jchannel_sync then match  chan.jchannel_id with
    | Chan (name, i) ->
        Transljoin.local_send_sync name i (Lvar z) Location.none
    | Alone g -> Lapply (Lvar g, [Lvar z],Location.none)
    else match chan.jchannel_id with
    | Chan (name, i) ->
        Transljoin.local_tail_send_async name i
          (Lvar z)  Location.none
    | Alone g ->
        Transljoin.local_tail_send_alone g (Lvar z)  Location.none in

  let body =
    try
      let allchans =
          List.map
            (fun (p, chan) -> match chan.jchannel_id with
            | Chan (auto,i) -> auto,(p,i)
            | Alone _ -> raise Exit)
            cls in
        match allchans with
        | [] -> assert false
        | (auto,_)::_ ->
            let cls =
              List.map
                (fun (_,(p,i)) ->
                  p,Lconst (Const_base (Const_int i)))
                allchans in
            (if chan.jchannel_sync then
              Transljoin.local_send_sync2
            else
              Transljoin.local_tail_send_async2)
              auto
              (Matching.for_function
                 (id_lam,Location.none) None (Lvar z)
                 cls partial)
              (Lvar z)
    with Exit ->
      let cls = List.map (fun (p, chan) -> p, rhs chan) cls in
      Matching.for_function
        (id_lam,Location.none) None (Lvar z) cls partial in
  let params = [z] in
  let lam =  Lfunction (Curried, params, body) in
  d_id, chan, lam

and transl_forwarder (Fwd reac) =
  let (x, jpat, _, idpats, p) = reac in
  let sync = Transljoin.principal p in
  let body =
    List.fold_right
      (fun (param, pat) lam ->
        Matching.for_function
          (id_lam, Location.none) None (Lvar param) [pat,lam] Total)
      idpats
      (transl_proc true sync p) in
  let param = match idpats with
  | [id,_] -> id
  | _      -> assert false in
  let lam = Lfunction (Curried, [param], body) in
  x, lam
    

(* transl_spawn separates e into a forked part and a part to execute now *)
and transl_spawn e =
  let _, seqs, forks = Transljoin.as_procs None e in
  let lforks =
    List.fold_right transl_fork forks lambda_unit in
  transl_as_seq false seqs lforks

(* Do perform a fork *)
and transl_fork e k = 
  make_sequence
    (Transljoin.do_spawn (transl_proc true None e) Location.none)
    k

(* Sequence for processes *)    

and transl_as_seq die es k = match es with
| [] -> k
| [e] -> make_sequence (transl_simple_proc die None e) k
| e::rem ->
    make_sequence
      (transl_simple_proc false None e)
      (transl_as_seq die rem k)

and transl_list transl_exp expr_list =
  List.map transl_exp expr_list

and transl_cases transl_exp pat_expr_list =
  List.map
    (fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
    pat_expr_list
(*< JOCAML *)

and transl_tupled_cases patl_expr_list =
  List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list

and transl_apply lam sargs loc =
  let lapply funct args =
    match funct with
      Lsend(k, lmet, lobj, largs, loc) ->
        Lsend(k, lmet, lobj, largs @ args, loc)
    | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
        Lsend(k, lmet, lobj, largs @ args, loc)
    | Lapply(lexp, largs, _) ->
        Lapply(lexp, largs @ args, loc)
    | lexp ->
        Lapply(lexp, args, loc)
  in
  let rec build_apply lam args = function
      (None, optional) :: l ->
        let defs = ref [] in
        let protect name lam =
          match lam with
            Lvar _ | Lconst _ -> lam
          | _ ->
              let id = Ident.create name in
              defs := (id, lam) :: !defs;
              Lvar id
        in
        let args, args' =
          if List.for_all (fun (_,opt) -> opt = Optional) args then [], args
          else args, [] in
        let lam =
          if args = [] then lam else lapply lam (List.rev_map fst args) in
        let handle = protect "func" lam
        and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
        and id_arg = Ident.create "param" in
        let body =
          match build_apply handle ((Lvar id_arg, optional)::args') l with
            Lfunction(Curried, ids, lam) ->
              Lfunction(Curried, id_arg::ids, lam)
          | Levent(Lfunction(Curried, ids, lam), _) ->
              Lfunction(Curried, id_arg::ids, lam)
          | lam ->
              Lfunction(Curried, [id_arg], lam)
        in
        List.fold_left
          (fun body (id, lam) -> Llet(Strict, id, lam, body))
          body !defs
    | (Some arg, optional) :: l ->
        build_apply lam ((arg, optional) :: args) l
    | [] ->
        lapply lam (List.rev_map fst args)
  in
  build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs)

and transl_function loc untuplify_fn repr partial pat_expr_list =
  match pat_expr_list with
    [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)]
    when Parmatch.fluid pat ->
      let param = name_pattern "param" pat_expr_list in
      let ((_, params), body) =
        transl_function exp.exp_loc false repr partial' pl in
      ((Curried, param :: params),
       Matching.for_function (id_lam,loc)
         None (Lvar param) [pat, body] partial)
  | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
      begin try
        let size = List.length pl in
        let pats_expr_list =
          List.map
            (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
            pat_expr_list in
        let params = List.map (fun p -> Ident.create "param") pl in
        ((Tupled, params),
         Matching.for_tupled_function loc params
           (transl_tupled_cases pats_expr_list) partial)
      with Matching.Cannot_flatten ->
        let param = name_pattern "param" pat_expr_list in
        ((Curried, [param]),
         Matching.for_function (id_lam,loc) repr (Lvar param)
           (transl_cases transl_exp pat_expr_list) partial)
      end
  | _ ->
      let param = name_pattern "param" pat_expr_list in
      ((Curried, [param]),
       Matching.for_function (id_lam,loc) repr (Lvar param)
         (transl_cases transl_exp pat_expr_list) partial)

and transl_let reply_handler transl_exp rec_flag pat_expr_list body =
  match rec_flag with
    Nonrecursive | Default ->
      let rec transl = function
        [] ->
          body
      | (pat, expr) :: rem ->
          Matching.for_let
            (reply_handler, pat.pat_loc) (transl_exp expr) pat (transl rem)
      in transl pat_expr_list
  | Recursive ->
      let idlist =
        List.map
          (fun (pat, expr) -> match pat.pat_desc with
              Tpat_var (id,_) -> id
            | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
            | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
        pat_expr_list in
      let transl_case (pat, expr) id =
        let lam = transl_exp expr in
        if not (check_recursive_lambda idlist lam) then
          raise(Error(expr.exp_loc, Illegal_letrec_expr));
        (id, lam) in
      Lletrec(List.map2 transl_case pat_expr_list idlist, body)
(*> JOCAML *)

and do_transl_def autos body =
      
(* compile (and name) real guarded processes *)
  let reactions =
    List.map
      (fun auto ->
        if auto.jauto_nchans = 0 then []
        else
          let _,reacs,_ = auto.jauto_desc in
          List.map (transl_reaction auto.jauto_name) reacs)
      autos in

(* compile firing of guarded processes (aka automaton table) *)
  let r =
    List.fold_right2
      Transljoin.create_table
      autos reactions body in

(* bind guarded processes *)
  let r =
    List.fold_right
      (fun reacs r ->
        List.fold_right
          (fun (x,_,lam) r -> Llet (Strict, x, lam, r))
          reacs  r)
      reactions r in

(* create dispatchers *)
  let disps =
    List.map
      (fun auto ->
        let disps,_,_ = auto.jauto_desc in
        List.map transl_dispatcher disps)
      autos
  and fwds =
    List.map
      (fun auto ->
        let _,_,fwds = auto.jauto_desc in
        List.map transl_forwarder fwds)
      autos in
  let r =
    if List.for_all
        (function | [] -> true | _::_ -> false)
        fwds then
      List.fold_right Transljoin.create_dispatchers disps r
    else
      Transljoin.create_forwarders autos disps fwds r in

(* create channels structures *)
  let r =
    List.fold_right Transljoin.create_channels autos r in
(* create automata structures *)
  let r =
    List.fold_right Transljoin.create_auto autos r in
  r


and transl_setinstvar self var expr =
  Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
                    [self; transl_path var; transl_exp expr])

and transl_record all_labels repres lbl_expr_list opt_init_expr =
  let size = Array.length all_labels in
  (* Determine if there are "enough" new fields *)
  if 3 + 2 * List.length lbl_expr_list >= size
  then begin
    (* Allocate new record with given fields (and remaining fields
       taken from init_expr if any *)
    let lv = Array.create (Array.length all_labels) staticfail in
    let init_id = Ident.create "init" in
    begin match opt_init_expr with
      None -> ()
    | Some init_expr ->
        for i = 0 to Array.length all_labels - 1 do
          let access =
            match all_labels.(i).lbl_repres with
              Record_regular -> Pfield i
            | Record_float -> Pfloatfield i in
          lv.(i) <- Lprim(access, [Lvar init_id])
        done
    end;
    List.iter
      (fun (_, _, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
      lbl_expr_list;
    let ll = Array.to_list lv in
    let mut =
      if List.exists (fun (_, _, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
      then Mutable
      else Immutable in
    let lam =
      try
        if mut = Mutable then raise Not_constant;
        let cl = List.map extract_constant ll in
        match repres with
          Record_regular -> Lconst(Const_block(0, cl))
        | Record_float ->
            Lconst(Const_float_array(List.map extract_float cl))
      with Not_constant ->
        match repres with
          Record_regular -> Lprim(Pmakeblock(0, mut), ll)
        | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
    begin match opt_init_expr with
      None -> lam
    | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam)
    end
  end else begin
    (* Take a shallow copy of the init record, then mutate the fields
       of the copy *)
    (* If you change anything here, you will likely have to change
       [check_recursive_recordwith] in this file. *)
    let copy_id = Ident.create "newrecord" in
    let rec update_field (_, _, lbl, expr) cont =
      let upd =
        match lbl.lbl_repres with
          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
        | Record_float -> Psetfloatfield lbl.lbl_pos in
      Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
    begin match opt_init_expr with
      None -> assert false
    | Some init_expr ->
        Llet(Strict, copy_id,
             Lprim(Pduprecord (repres, size), [transl_exp init_expr]),
             List.fold_right update_field lbl_expr_list (Lvar copy_id))
    end
  end

(*> JOCAML *)
(* For external usage *)
let transl_def d k = do_transl_def d k
and transl_loc d k = assert false
and transl_let = transl_let id_lam transl_exp
(*< JOCAML *)

(* Wrapper for class compilation *)


(* Compile an exception definition *)

let transl_exception id path decl =
  let name =
    match path with
      None -> Ident.name id
    | Some p -> Path.name p in
  Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))])

(* Error report *)

open Format

let report_error ppf = function
  | Illegal_letrec_pat ->
      fprintf ppf
        "Only variables are allowed as left-hand side of `let rec'"
  | Illegal_letrec_expr ->
      fprintf ppf
        "This kind of expression is not allowed as right-hand side of `let rec'"
  | Free_super_var ->
      fprintf ppf
        "Ancestor names can only be used to select inherited methods"
  | Unknown_builtin_primitive prim_name ->
    fprintf ppf  "Unknown builtin primitive \"%s\"" prim_name