472 lines
15 KiB
OCaml
472 lines
15 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
open Misc
|
|
open Path
|
|
open Asttypes
|
|
|
|
type compile_time_constant =
|
|
| Big_endian
|
|
| Word_size
|
|
| Ostype_unix
|
|
| Ostype_win32
|
|
| Ostype_cygwin
|
|
|
|
type primitive =
|
|
Pidentity
|
|
| Pignore
|
|
| Prevapply of Location.t
|
|
| Pdirapply of Location.t
|
|
(* Globals *)
|
|
| Pgetglobal of Ident.t
|
|
| Psetglobal of Ident.t
|
|
(* Operations on heap blocks *)
|
|
| Pmakeblock of int * mutable_flag
|
|
| Pfield of int
|
|
| Psetfield of int * bool
|
|
| Pfloatfield of int
|
|
| Psetfloatfield of int
|
|
| Pduprecord of Types.record_representation * int
|
|
(* Force lazy values *)
|
|
| Plazyforce
|
|
(* External call *)
|
|
| Pccall of Primitive.description
|
|
(* Exceptions *)
|
|
| Praise of raise_kind
|
|
(* Boolean operations *)
|
|
| Psequand | Psequor | Pnot
|
|
(* Integer operations *)
|
|
| Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
|
|
| Pandint | Porint | Pxorint
|
|
| Plslint | Plsrint | Pasrint
|
|
| Pintcomp of comparison
|
|
| Poffsetint of int
|
|
| Poffsetref of int
|
|
(* Float operations *)
|
|
| Pintoffloat | Pfloatofint
|
|
| Pnegfloat | Pabsfloat
|
|
| Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
|
|
| Pfloatcomp of comparison
|
|
(* String operations *)
|
|
| Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
|
|
(* Array operations *)
|
|
| Pmakearray of array_kind
|
|
| Parraylength of array_kind
|
|
| Parrayrefu of array_kind
|
|
| Parraysetu of array_kind
|
|
| Parrayrefs of array_kind
|
|
| Parraysets of array_kind
|
|
(* Test if the argument is a block or an immediate integer *)
|
|
| Pisint
|
|
(* Test if the (integer) argument is outside an interval *)
|
|
| Pisout
|
|
(* Bitvect operations *)
|
|
| Pbittest
|
|
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
|
|
| Pbintofint of boxed_integer
|
|
| Pintofbint of boxed_integer
|
|
| Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
|
|
| Pnegbint of boxed_integer
|
|
| Paddbint of boxed_integer
|
|
| Psubbint of boxed_integer
|
|
| Pmulbint of boxed_integer
|
|
| Pdivbint of boxed_integer
|
|
| Pmodbint of boxed_integer
|
|
| Pandbint of boxed_integer
|
|
| Porbint of boxed_integer
|
|
| Pxorbint of boxed_integer
|
|
| Plslbint of boxed_integer
|
|
| Plsrbint of boxed_integer
|
|
| Pasrbint of boxed_integer
|
|
| Pbintcomp of boxed_integer * comparison
|
|
(* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
|
|
| Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
|
|
| Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
|
|
(* size of the nth dimension of a big array *)
|
|
| Pbigarraydim of int
|
|
(* load/set 16,32,64 bits from a string: (unsafe)*)
|
|
| Pstring_load_16 of bool
|
|
| Pstring_load_32 of bool
|
|
| Pstring_load_64 of bool
|
|
| Pstring_set_16 of bool
|
|
| Pstring_set_32 of bool
|
|
| Pstring_set_64 of bool
|
|
(* load/set 16,32,64 bits from a
|
|
(char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
|
|
| Pbigstring_load_16 of bool
|
|
| Pbigstring_load_32 of bool
|
|
| Pbigstring_load_64 of bool
|
|
| Pbigstring_set_16 of bool
|
|
| Pbigstring_set_32 of bool
|
|
| Pbigstring_set_64 of bool
|
|
(* Compile time constants *)
|
|
| Pctconst of compile_time_constant
|
|
(* byte swap *)
|
|
| Pbswap16
|
|
| Pbbswap of boxed_integer
|
|
|
|
and comparison =
|
|
Ceq | Cneq | Clt | Cgt | Cle | Cge
|
|
|
|
and array_kind =
|
|
Pgenarray | Paddrarray | Pintarray | Pfloatarray
|
|
|
|
and boxed_integer =
|
|
Pnativeint | Pint32 | Pint64
|
|
|
|
and bigarray_kind =
|
|
Pbigarray_unknown
|
|
| Pbigarray_float32 | Pbigarray_float64
|
|
| Pbigarray_sint8 | Pbigarray_uint8
|
|
| Pbigarray_sint16 | Pbigarray_uint16
|
|
| Pbigarray_int32 | Pbigarray_int64
|
|
| Pbigarray_caml_int | Pbigarray_native_int
|
|
| Pbigarray_complex32 | Pbigarray_complex64
|
|
|
|
and bigarray_layout =
|
|
Pbigarray_unknown_layout
|
|
| Pbigarray_c_layout
|
|
| Pbigarray_fortran_layout
|
|
|
|
and raise_kind =
|
|
| Raise_regular
|
|
| Raise_reraise
|
|
| Raise_notrace
|
|
|
|
type structured_constant =
|
|
Const_base of constant
|
|
| Const_pointer of int
|
|
| Const_block of int * structured_constant list
|
|
| Const_float_array of string list
|
|
| Const_immstring of string
|
|
|
|
type function_kind = Curried | Tupled
|
|
|
|
type let_kind = Strict | Alias | StrictOpt | Variable
|
|
|
|
type meth_kind = Self | Public | Cached
|
|
|
|
type shared_code = (int * int) list
|
|
|
|
type lambda =
|
|
Lvar of Ident.t
|
|
| Lconst of structured_constant
|
|
| Lapply of lambda * lambda list * Location.t
|
|
| Lfunction of function_kind * Ident.t list * lambda
|
|
| Llet of let_kind * Ident.t * lambda * lambda
|
|
| Lletrec of (Ident.t * lambda) list * lambda
|
|
| Lprim of primitive * lambda list
|
|
| Lswitch of lambda * lambda_switch
|
|
| Lstaticraise of int * lambda list
|
|
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
|
|
| Ltrywith of lambda * Ident.t * lambda
|
|
| Lifthenelse of lambda * lambda * lambda
|
|
| Lsequence of lambda * lambda
|
|
| Lwhile of lambda * lambda
|
|
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
|
|
| Lassign of Ident.t * lambda
|
|
| Lsend of meth_kind * lambda * lambda * lambda list * Location.t
|
|
| Levent of lambda * lambda_event
|
|
| Lifused of Ident.t * lambda
|
|
|
|
and lambda_switch =
|
|
{ sw_numconsts: int;
|
|
sw_consts: (int * lambda) list;
|
|
sw_numblocks: int;
|
|
sw_blocks: (int * lambda) list;
|
|
sw_failaction : lambda option}
|
|
|
|
and lambda_event =
|
|
{ lev_loc: Location.t;
|
|
lev_kind: lambda_event_kind;
|
|
lev_repr: int ref option;
|
|
lev_env: Env.summary }
|
|
|
|
and lambda_event_kind =
|
|
Lev_before
|
|
| Lev_after of Types.type_expr
|
|
| Lev_function
|
|
|
|
let const_unit = Const_pointer 0
|
|
|
|
let lambda_unit = Lconst const_unit
|
|
|
|
let rec same l1 l2 =
|
|
match (l1, l2) with
|
|
| Lvar v1, Lvar v2 ->
|
|
Ident.same v1 v2
|
|
| Lconst (Const_base (Const_string _)), _ ->
|
|
false (* do not share strings *)
|
|
| Lconst c1, Lconst c2 ->
|
|
c1 = c2
|
|
| Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
|
|
same a1 a2 && samelist same bl1 bl2
|
|
| Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
|
|
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
|
|
| Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) ->
|
|
k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2
|
|
| Lletrec (bl1, a1), Lletrec (bl2, a2) ->
|
|
samelist samebinding bl1 bl2 && same a1 a2
|
|
| Lprim(p1, al1), Lprim(p2, al2) ->
|
|
p1 = p2 && samelist same al1 al2
|
|
| Lswitch(a1, s1), Lswitch(a2, s2) ->
|
|
same a1 a2 && sameswitch s1 s2
|
|
| Lstaticraise(n1, al1), Lstaticraise(n2, al2) ->
|
|
n1 = n2 && samelist same al1 al2
|
|
| Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) ->
|
|
same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2
|
|
| Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) ->
|
|
same a1 a2 && Ident.same id1 id2 && same b1 b2
|
|
| Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) ->
|
|
same a1 a2 && same b1 b2 && same c1 c2
|
|
| Lsequence(a1, b1), Lsequence(a2, b2) ->
|
|
same a1 a2 && same b1 b2
|
|
| Lwhile(a1, b1), Lwhile(a2, b2) ->
|
|
same a1 a2 && same b1 b2
|
|
| Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) ->
|
|
Ident.same id1 id2 && same a1 a2 &&
|
|
same b1 b2 && df1 = df2 && same c1 c2
|
|
| Lassign(id1, a1), Lassign(id2, a2) ->
|
|
Ident.same id1 id2 && same a1 a2
|
|
| Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
|
|
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
|
|
| Levent(a1, ev1), Levent(a2, ev2) ->
|
|
same a1 a2 && ev1.lev_loc = ev2.lev_loc
|
|
| Lifused(id1, a1), Lifused(id2, a2) ->
|
|
Ident.same id1 id2 && same a1 a2
|
|
| _, _ ->
|
|
false
|
|
|
|
and samebinding (id1, c1) (id2, c2) =
|
|
Ident.same id1 id2 && same c1 c2
|
|
|
|
and sameswitch sw1 sw2 =
|
|
let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in
|
|
sw1.sw_numconsts = sw2.sw_numconsts &&
|
|
sw1.sw_numblocks = sw2.sw_numblocks &&
|
|
samelist samecase sw1.sw_consts sw2.sw_consts &&
|
|
samelist samecase sw1.sw_blocks sw2.sw_blocks &&
|
|
(match (sw1.sw_failaction, sw2.sw_failaction) with
|
|
| (None, None) -> true
|
|
| (Some a1, Some a2) -> same a1 a2
|
|
| _ -> false)
|
|
|
|
let name_lambda strict arg fn =
|
|
match arg with
|
|
Lvar id -> fn id
|
|
| _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id)
|
|
|
|
let name_lambda_list args fn =
|
|
let rec name_list names = function
|
|
[] -> fn (List.rev names)
|
|
| (Lvar id as arg) :: rem ->
|
|
name_list (arg :: names) rem
|
|
| arg :: rem ->
|
|
let id = Ident.create "let" in
|
|
Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
|
|
name_list [] args
|
|
|
|
let iter f = function
|
|
Lvar _
|
|
| Lconst _ -> ()
|
|
| Lapply(fn, args, _) ->
|
|
f fn; List.iter f args
|
|
| Lfunction(kind, params, body) ->
|
|
f body
|
|
| Llet(str, id, arg, body) ->
|
|
f arg; f body
|
|
| Lletrec(decl, body) ->
|
|
f body;
|
|
List.iter (fun (id, exp) -> f exp) decl
|
|
| Lprim(p, args) ->
|
|
List.iter f args
|
|
| Lswitch(arg, sw) ->
|
|
f arg;
|
|
List.iter (fun (key, case) -> f case) sw.sw_consts;
|
|
List.iter (fun (key, case) -> f case) sw.sw_blocks;
|
|
begin match sw.sw_failaction with
|
|
| None -> ()
|
|
| Some l -> f l
|
|
end
|
|
| Lstaticraise (_,args) ->
|
|
List.iter f args
|
|
| Lstaticcatch(e1, (_,vars), e2) ->
|
|
f e1; f e2
|
|
| Ltrywith(e1, exn, e2) ->
|
|
f e1; f e2
|
|
| Lifthenelse(e1, e2, e3) ->
|
|
f e1; f e2; f e3
|
|
| Lsequence(e1, e2) ->
|
|
f e1; f e2
|
|
| Lwhile(e1, e2) ->
|
|
f e1; f e2
|
|
| Lfor(v, e1, e2, dir, e3) ->
|
|
f e1; f e2; f e3
|
|
| Lassign(id, e) ->
|
|
f e
|
|
| Lsend (k, met, obj, args, _) ->
|
|
List.iter f (met::obj::args)
|
|
| Levent (lam, evt) ->
|
|
f lam
|
|
| Lifused (v, e) ->
|
|
f e
|
|
|
|
module IdentSet =
|
|
Set.Make(struct
|
|
type t = Ident.t
|
|
let compare = compare
|
|
end)
|
|
|
|
let free_ids get l =
|
|
let fv = ref IdentSet.empty in
|
|
let rec free l =
|
|
iter free l;
|
|
fv := List.fold_right IdentSet.add (get l) !fv;
|
|
match l with
|
|
Lfunction(kind, params, body) ->
|
|
List.iter (fun param -> fv := IdentSet.remove param !fv) params
|
|
| Llet(str, id, arg, body) ->
|
|
fv := IdentSet.remove id !fv
|
|
| Lletrec(decl, body) ->
|
|
List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
|
|
| Lstaticcatch(e1, (_,vars), e2) ->
|
|
List.iter (fun id -> fv := IdentSet.remove id !fv) vars
|
|
| Ltrywith(e1, exn, e2) ->
|
|
fv := IdentSet.remove exn !fv
|
|
| Lfor(v, e1, e2, dir, e3) ->
|
|
fv := IdentSet.remove v !fv
|
|
| Lassign(id, e) ->
|
|
fv := IdentSet.add id !fv
|
|
| Lvar _ | Lconst _ | Lapply _
|
|
| Lprim _ | Lswitch _ | Lstaticraise _
|
|
| Lifthenelse _ | Lsequence _ | Lwhile _
|
|
| Lsend _ | Levent _ | Lifused _ -> ()
|
|
in free l; !fv
|
|
|
|
let free_variables l =
|
|
free_ids (function Lvar id -> [id] | _ -> []) l
|
|
|
|
let free_methods l =
|
|
free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
|
|
|
|
(* Check if an action has a "when" guard *)
|
|
let raise_count = ref 0
|
|
|
|
let next_raise_count () =
|
|
incr raise_count ;
|
|
!raise_count
|
|
|
|
(* Anticipated staticraise, for guards *)
|
|
let staticfail = Lstaticraise (0,[])
|
|
|
|
let rec is_guarded = function
|
|
| Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
|
|
| Llet(str, id, lam, body) -> is_guarded body
|
|
| Levent(lam, ev) -> is_guarded lam
|
|
| _ -> false
|
|
|
|
let rec patch_guarded patch = function
|
|
| Lifthenelse (cond, body, Lstaticraise (0,[])) ->
|
|
Lifthenelse (cond, body, patch)
|
|
| Llet(str, id, lam, body) ->
|
|
Llet (str, id, lam, patch_guarded patch body)
|
|
| Levent(lam, ev) ->
|
|
Levent (patch_guarded patch lam, ev)
|
|
| _ -> fatal_error "Lambda.patch_guarded"
|
|
|
|
(* Translate an access path *)
|
|
|
|
let rec transl_normal_path = function
|
|
Pident id ->
|
|
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
|
|
| Pdot(p, s, pos) ->
|
|
Lprim(Pfield pos, [transl_normal_path p])
|
|
| Papply(p1, p2) ->
|
|
fatal_error "Lambda.transl_path"
|
|
|
|
(* Translation of value identifiers *)
|
|
|
|
let transl_path ?(loc=Location.none) env path =
|
|
transl_normal_path (Env.normalize_path (Some loc) env path)
|
|
|
|
(* Compile a sequence of expressions *)
|
|
|
|
let rec make_sequence fn = function
|
|
[] -> lambda_unit
|
|
| [x] -> fn x
|
|
| x::rem ->
|
|
let lam = fn x in Lsequence(lam, make_sequence fn rem)
|
|
|
|
(* Apply a substitution to a lambda-term.
|
|
Assumes that the bound variables of the lambda-term do not
|
|
belong to the domain of the substitution.
|
|
Assumes that the image of the substitution is out of reach
|
|
of the bound variables of the lambda-term (no capture). *)
|
|
|
|
let subst_lambda s lam =
|
|
let rec subst = function
|
|
Lvar id as l ->
|
|
begin try Ident.find_same id s with Not_found -> l end
|
|
| Lconst sc as l -> l
|
|
| Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
|
|
| Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
|
|
| Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
|
|
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
|
|
| Lprim(p, args) -> Lprim(p, List.map subst args)
|
|
| Lswitch(arg, sw) ->
|
|
Lswitch(subst arg,
|
|
{sw with sw_consts = List.map subst_case sw.sw_consts;
|
|
sw_blocks = List.map subst_case sw.sw_blocks;
|
|
sw_failaction =
|
|
match sw.sw_failaction with
|
|
| None -> None
|
|
| Some l -> Some (subst l)})
|
|
|
|
| Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
|
|
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
|
|
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
|
|
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
|
|
| Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
|
|
| Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
|
|
| Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
|
|
| Lassign(id, e) -> Lassign(id, subst e)
|
|
| Lsend (k, met, obj, args, loc) ->
|
|
Lsend (k, subst met, subst obj, List.map subst args, loc)
|
|
| Levent (lam, evt) -> Levent (subst lam, evt)
|
|
| Lifused (v, e) -> Lifused (v, subst e)
|
|
and subst_decl (id, exp) = (id, subst exp)
|
|
and subst_case (key, case) = (key, subst case)
|
|
in subst lam
|
|
|
|
|
|
(* To let-bind expressions to variables *)
|
|
|
|
let bind str var exp body =
|
|
match exp with
|
|
Lvar var' when Ident.same var var' -> body
|
|
| _ -> Llet(str, var, exp, body)
|
|
|
|
and commute_comparison = function
|
|
| Ceq -> Ceq| Cneq -> Cneq
|
|
| Clt -> Cgt | Cle -> Cge
|
|
| Cgt -> Clt | Cge -> Cle
|
|
|
|
and negate_comparison = function
|
|
| Ceq -> Cneq| Cneq -> Ceq
|
|
| Clt -> Cge | Cle -> Cgt
|
|
| Cgt -> Cle | Cge -> Clt
|
|
|
|
let raise_kind = function
|
|
| Raise_regular -> "raise"
|
|
| Raise_reraise -> "reraise"
|
|
| Raise_notrace -> "raise_notrace"
|