855 lines
31 KiB
OCaml
855 lines
31 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
(* 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
|
|
|
|
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)
|
|
|
|
(* Translation of primitives *)
|
|
|
|
let comparisons_table = create_hashtable 11 [
|
|
"%equal",
|
|
(Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Ceq,
|
|
Pfloatcomp Ceq,
|
|
Pccall{prim_name = "string_equal"; prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Ceq),
|
|
Pbintcomp(Pint32, Ceq),
|
|
Pbintcomp(Pint64, Ceq));
|
|
"%notequal",
|
|
(Pccall{prim_name = "notequal"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Cneq,
|
|
Pfloatcomp Cneq,
|
|
Pccall{prim_name = "string_notequal"; prim_arity = 2;
|
|
prim_alloc = false; prim_native_name = "";
|
|
prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Cneq),
|
|
Pbintcomp(Pint32, Cneq),
|
|
Pbintcomp(Pint64, Cneq));
|
|
"%lessthan",
|
|
(Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Clt,
|
|
Pfloatcomp Clt,
|
|
Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Clt),
|
|
Pbintcomp(Pint32, Clt),
|
|
Pbintcomp(Pint64, Clt));
|
|
"%greaterthan",
|
|
(Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Cgt,
|
|
Pfloatcomp Cgt,
|
|
Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Cgt),
|
|
Pbintcomp(Pint32, Cgt),
|
|
Pbintcomp(Pint64, Cgt));
|
|
"%lessequal",
|
|
(Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Cle,
|
|
Pfloatcomp Cle,
|
|
Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Cle),
|
|
Pbintcomp(Pint32, Cle),
|
|
Pbintcomp(Pint64, Cle));
|
|
"%greaterequal",
|
|
(Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pintcomp Cge,
|
|
Pfloatcomp Cge,
|
|
Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
|
|
prim_native_name = ""; prim_native_float = false},
|
|
Pbintcomp(Pnativeint, Cge),
|
|
Pbintcomp(Pint32, Cge),
|
|
Pbintcomp(Pint64, Cge))
|
|
]
|
|
|
|
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;
|
|
"%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);
|
|
"%bigarray_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout);
|
|
"%bigarray_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout);
|
|
"%bigarray_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout);
|
|
"%bigarray_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout);
|
|
"%bigarray_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout);
|
|
"%bigarray_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout)
|
|
]
|
|
|
|
let prim_makearray =
|
|
{ prim_name = "make_vect"; prim_arity = 2; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false }
|
|
|
|
let prim_obj_dup =
|
|
{ prim_name = "obj_dup"; prim_arity = 1; prim_alloc = true;
|
|
prim_native_name = ""; prim_native_float = false }
|
|
|
|
let transl_prim prim args =
|
|
try
|
|
let (gencomp, intcomp, floatcomp, stringcomp,
|
|
nativeintcomp, int32comp, int64comp) =
|
|
Hashtbl.find comparisons_table prim.prim_name in
|
|
begin match args with
|
|
[arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] ->
|
|
intcomp
|
|
| [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] ->
|
|
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 = Hashtbl.find primitives_table prim.prim_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(n, Pbigarray_unknown, _), arg1 :: _) ->
|
|
let (k, l) = bigarray_kind_and_layout arg1 in
|
|
Pbigarrayref(n, k, l)
|
|
| (Pbigarrayset(n, Pbigarray_unknown, _), arg1 :: _) ->
|
|
let (k, l) = bigarray_kind_and_layout arg1 in
|
|
Pbigarrayset(n, k, l)
|
|
| _ -> p
|
|
end
|
|
with Not_found ->
|
|
Pccall prim
|
|
|
|
|
|
(* 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
|
|
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
|
|
Lfunction(kind, params, body) as funct -> true
|
|
| Lprim(Pmakeblock(tag, mut), args) ->
|
|
List.for_all (check idlist) args
|
|
| Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
|
|
List.for_all (check idlist) args
|
|
| 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
|
|
| Levent (lam, _) -> check_top idlist lam
|
|
| _ -> false
|
|
|
|
and check idlist = function
|
|
Lvar _ -> true
|
|
| Lconst cst -> true
|
|
| Lfunction(kind, params, body) -> 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(Paddrarray|Pintarray), args) ->
|
|
List.for_all (check idlist) args
|
|
| Levent (lam, _) -> check idlist lam
|
|
| lam ->
|
|
let fv = free_variables lam in
|
|
List.for_all (fun id -> not(IdentSet.mem id fv)) idlist
|
|
|
|
and add_let id arg idlist =
|
|
match arg with
|
|
Lvar id' -> if List.mem id' idlist then id :: idlist else idlist
|
|
| Llet(_, _, _, body) -> add_let id body idlist
|
|
| Lletrec(_, body) -> add_let id body idlist
|
|
| _ -> idlist
|
|
|
|
and add_letrec bindings idlist =
|
|
List.fold_right (fun (id, arg) idl -> add_let id arg idl)
|
|
bindings idlist
|
|
|
|
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 *)
|
|
|
|
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(pl,partial)} as exp)] ->
|
|
let pl = push_defaults exp.exp_loc bindings pl partial in
|
|
[pat, {exp with exp_desc = Texp_function(pl, partial)}]
|
|
| [pat, ({exp_desc = Texp_let
|
|
(Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] ->
|
|
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 exp =
|
|
{ exp with exp_loc = loc; exp_desc =
|
|
Texp_match
|
|
({exp with exp_type = pat.pat_type; exp_desc =
|
|
Texp_ident (Path.Pident param,
|
|
{val_type = pat.pat_type; val_kind = Val_reg})},
|
|
pat_expr_list, partial) }
|
|
in
|
|
push_defaults loc bindings
|
|
[{pat with pat_desc = Tpat_var param}, 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_pos = exp.exp_loc.Location.loc_start;
|
|
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_pos = exp.exp_loc.Location.loc_end;
|
|
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_pos = exp.exp_loc.Location.loc_start;
|
|
lev_kind = Lev_function;
|
|
lev_repr = repr;
|
|
lev_env = Env.summary exp.exp_env}))
|
|
else
|
|
lam None
|
|
|
|
|
|
let assert_failed loc =
|
|
let fname = match loc.Location.loc_start.Lexing.pos_fname with
|
|
| "" -> !Location.input_name
|
|
| x -> x
|
|
in
|
|
let pos = loc.Location.loc_start in
|
|
let line = pos.Lexing.pos_lnum in
|
|
let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
|
|
Lprim(Praise, [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)]))])])
|
|
;;
|
|
|
|
(* Translation of expressions *)
|
|
|
|
let rec transl_exp e =
|
|
match e.exp_desc with
|
|
Texp_ident(path, {val_kind = Val_prim p}) ->
|
|
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 _}) ->
|
|
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 rec_flag pat_expr_list (event_before body (transl_exp body))
|
|
| 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)
|
|
| Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
|
|
when List.length args = p.prim_arity
|
|
&& List.for_all (fun (arg,_) -> arg <> None) args ->
|
|
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
|
|
let prim = transl_prim p args in
|
|
begin match (prim, args) with
|
|
(Praise, [arg1]) ->
|
|
Lprim(Praise, [event_after arg1 (transl_exp arg1)])
|
|
| (Pccall _, _) ->
|
|
event_after e (Lprim(prim, transl_list args))
|
|
| (_, _) ->
|
|
Lprim(prim, transl_list args)
|
|
end
|
|
| Texp_apply(funct, oargs) ->
|
|
event_after e (transl_apply (transl_exp funct) oargs)
|
|
| Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
|
|
Matching.for_multiple_match e.exp_loc
|
|
(transl_list argl) (transl_cases pat_expr_list) partial
|
|
| Texp_match(arg, pat_expr_list, partial) ->
|
|
Matching.for_function e.exp_loc None
|
|
(transl_exp arg) (transl_cases 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 pat_expr_list))
|
|
| Texp_tuple el ->
|
|
let ll = transl_list 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 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 len = List.length expr_list in
|
|
if len <= Config.max_young_wosize then
|
|
Lprim(Pmakearray kind, transl_list expr_list)
|
|
else begin
|
|
let v = Ident.create "makearray" in
|
|
let rec fill_fields pos = function
|
|
[] ->
|
|
Lvar v
|
|
| arg :: rem ->
|
|
Lsequence(Lprim(Parraysetu kind,
|
|
[Lvar v;
|
|
Lconst(Const_base(Const_int pos));
|
|
transl_exp arg]),
|
|
fill_fields (pos+1) rem) in
|
|
Llet(Strict, v,
|
|
Lprim(Pccall prim_makearray,
|
|
[Lconst(Const_base(Const_int len));
|
|
transl_exp (List.hd expr_list)]),
|
|
fill_fields 1 (List.tl expr_list))
|
|
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(expr, met) ->
|
|
let met_id =
|
|
match met with
|
|
Tmeth_name nm -> Translobj.meth nm
|
|
| Tmeth_val id -> id
|
|
in
|
|
event_after e (Lsend(Lvar met_id, transl_exp expr, []))
|
|
| Texp_new (cl, _) ->
|
|
Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
|
|
| 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]),
|
|
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_assert (cond) ->
|
|
if !Clflags.noassert
|
|
then lambda_unit
|
|
else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
|
|
| Texp_assertfalse -> assert_failed e.exp_loc
|
|
| Texp_lazy e ->
|
|
let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
|
|
Lprim(Pmakeblock(Obj.lazy_tag, Immutable), [fn])
|
|
|
|
and transl_list expr_list =
|
|
List.map transl_exp expr_list
|
|
|
|
and transl_cases pat_expr_list =
|
|
List.map
|
|
(fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
|
|
pat_expr_list
|
|
|
|
and transl_tupled_cases patl_expr_list =
|
|
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
|
|
|
|
and transl_apply lam sargs =
|
|
let lapply funct args =
|
|
match funct with
|
|
Lsend(lmet, lobj, largs) ->
|
|
Lsend(lmet, lobj, largs @ args)
|
|
| Levent(Lsend(lmet, lobj, largs), _) ->
|
|
Lsend(lmet, lobj, largs @ args)
|
|
| Lapply(lexp, largs) ->
|
|
Lapply(lexp, largs @ args)
|
|
| lexp ->
|
|
Lapply(lexp, args)
|
|
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 (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)] ->
|
|
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 loc None (Lvar param) [pat, body] partial)
|
|
(*
|
|
| [({pat_desc = Tpat_var id} as pat),
|
|
({exp_desc = Texp_let(Nonrecursive, cases,
|
|
({exp_desc = Texp_function _} as e2))} as e1)]
|
|
when Ident.name id = "*opt*" ->
|
|
transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
|
|
| [pat, exp] when bindings <> [] ->
|
|
let exp =
|
|
List.fold_left
|
|
(fun exp cases ->
|
|
{exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
|
|
exp bindings
|
|
in
|
|
transl_function loc untuplify_fn repr [] partial [pat, exp]
|
|
| (pat, exp)::_ when bindings <> [] ->
|
|
let param = name_pattern "param" pat_expr_list 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,
|
|
{val_type = pat.pat_type; val_kind = Val_reg})},
|
|
pat_expr_list, partial) }
|
|
in
|
|
transl_function loc untuplify_fn repr bindings Total
|
|
[{pat with pat_desc = Tpat_var param}, exp]
|
|
*)
|
|
| ({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 loc repr (Lvar param)
|
|
(transl_cases pat_expr_list) partial)
|
|
end
|
|
| _ ->
|
|
let param = name_pattern "param" pat_expr_list in
|
|
((Curried, [param]),
|
|
Matching.for_function loc repr (Lvar param)
|
|
(transl_cases pat_expr_list) partial)
|
|
|
|
and transl_let rec_flag pat_expr_list body =
|
|
match rec_flag with
|
|
Nonrecursive | Default ->
|
|
let rec transl = function
|
|
[] ->
|
|
body
|
|
| (pat, expr) :: rem ->
|
|
Matching.for_let 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
|
|
| _ -> 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)
|
|
|
|
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 =
|
|
(* Determine if there are "enough" new fields *)
|
|
if 3 + 2 * List.length lbl_expr_list >= Array.length all_labels
|
|
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 *)
|
|
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(Pccall prim_obj_dup, [transl_exp init_expr]),
|
|
List.fold_right update_field lbl_expr_list (Lvar copy_id))
|
|
end
|
|
end
|
|
|
|
(* 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"
|