295 lines
9.3 KiB
OCaml
295 lines
9.3 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$ *)
|
|
|
|
open Misc
|
|
open Path
|
|
open Asttypes
|
|
|
|
type primitive =
|
|
Pidentity
|
|
| Pignore
|
|
(* 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
|
|
(* External call *)
|
|
| Pccall of Primitive.description
|
|
(* Exceptions *)
|
|
| Praise
|
|
(* 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
|
|
(* 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 *)
|
|
| Pbigarrayref of int * bigarray_kind * bigarray_layout
|
|
| Pbigarrayset of int * bigarray_kind * bigarray_layout
|
|
|
|
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
|
|
|
|
and bigarray_layout =
|
|
Pbigarray_unknown_layout
|
|
| Pbigarray_c_layout
|
|
| Pbigarray_fortran_layout
|
|
|
|
type structured_constant =
|
|
Const_base of constant
|
|
| Const_pointer of int
|
|
| Const_block of int * structured_constant list
|
|
| Const_float_array of string list
|
|
|
|
type function_kind = Curried | Tupled
|
|
|
|
type let_kind = Strict | Alias | StrictOpt | Variable
|
|
|
|
type shared_code = (int * int) list
|
|
|
|
type lambda =
|
|
Lvar of Ident.t
|
|
| Lconst of structured_constant
|
|
| Lapply of lambda * lambda list
|
|
| 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
|
|
| Lstaticfail
|
|
| Lcatch of lambda * lambda
|
|
| Lstaticraise of int
|
|
| Lstaticcatch of lambda * int * 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 lambda * lambda * lambda list
|
|
| 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_checked: bool ;
|
|
sw_nofail: bool }
|
|
|
|
and lambda_event =
|
|
{ lev_loc: int;
|
|
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 name_lambda 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
|
|
|
|
module IdentSet =
|
|
Set.Make(struct
|
|
type t = Ident.t
|
|
let compare = compare
|
|
end)
|
|
|
|
let free_variables l =
|
|
let fv = ref IdentSet.empty in
|
|
let rec freevars = function
|
|
Lvar id ->
|
|
fv := IdentSet.add id !fv
|
|
| Lconst sc -> ()
|
|
| Lapply(fn, args) ->
|
|
freevars fn; List.iter freevars args
|
|
| Lfunction(kind, params, body) ->
|
|
freevars body;
|
|
List.iter (fun param -> fv := IdentSet.remove param !fv) params
|
|
| Llet(str, id, arg, body) ->
|
|
freevars arg; freevars body; fv := IdentSet.remove id !fv
|
|
| Lletrec(decl, body) ->
|
|
freevars body;
|
|
List.iter (fun (id, exp) -> freevars exp) decl;
|
|
List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
|
|
| Lprim(p, args) ->
|
|
List.iter freevars args
|
|
| Lswitch(arg, sw) ->
|
|
freevars arg;
|
|
List.iter (fun (key, case) -> freevars case) sw.sw_consts;
|
|
List.iter (fun (key, case) -> freevars case) sw.sw_blocks
|
|
| Lstaticfail -> ()
|
|
| Lcatch(e1, e2) ->
|
|
freevars e1; freevars e2
|
|
| Lstaticraise _ -> ()
|
|
| Lstaticcatch(e1, _, e2) ->
|
|
freevars e1; freevars e2
|
|
| Ltrywith(e1, exn, e2) ->
|
|
freevars e1; freevars e2; fv := IdentSet.remove exn !fv
|
|
| Lifthenelse(e1, e2, e3) ->
|
|
freevars e1; freevars e2; freevars e3
|
|
| Lsequence(e1, e2) ->
|
|
freevars e1; freevars e2
|
|
| Lwhile(e1, e2) ->
|
|
freevars e1; freevars e2
|
|
| Lfor(v, e1, e2, dir, e3) ->
|
|
freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
|
|
| Lassign(id, e) ->
|
|
fv := IdentSet.add id !fv; freevars e
|
|
| Lsend (met, obj, args) ->
|
|
List.iter freevars (met::obj::args)
|
|
| Levent (lam, evt) ->
|
|
freevars lam
|
|
| Lifused (v, e) ->
|
|
freevars e
|
|
in freevars l; !fv
|
|
|
|
(* Check if an action has a "when" guard *)
|
|
|
|
let rec is_guarded = function
|
|
Lifthenelse(cond, body, Lstaticfail) -> true
|
|
| Llet(str, id, lam, body) -> is_guarded body
|
|
| Levent(lam, ev) -> is_guarded lam
|
|
| _ -> false
|
|
|
|
(* Translate an access path *)
|
|
|
|
let rec transl_path = function
|
|
Pident id ->
|
|
if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
|
|
| Pdot(p, s, pos) ->
|
|
Lprim(Pfield pos, [transl_path p])
|
|
| Papply(p1, p2) ->
|
|
fatal_error "Lambda.transl_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) -> Lapply(subst fn, List.map subst args)
|
|
| 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})
|
|
| Lstaticfail as l -> l
|
|
| Lcatch(e1, e2) -> Lcatch(subst e1, subst e2)
|
|
| Lstaticraise i as l -> l
|
|
| 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 (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args)
|
|
| 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
|