1995-08-09 08:06:35 -07:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
1996-04-30 07:53:58 -07:00
|
|
|
(* Objective Caml *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
|
|
(* *)
|
1996-04-30 07:53:58 -07:00
|
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
1999-11-17 10:59:06 -08:00
|
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
|
|
(* under the terms of the Q Public License version 1.0. *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
|
|
|
|
|
|
|
(* $Id$ *)
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* The "lambda" intermediate code *)
|
|
|
|
|
|
|
|
open Asttypes
|
|
|
|
|
|
|
|
type primitive =
|
|
|
|
Pidentity
|
1999-02-24 07:21:50 -08:00
|
|
|
| Pignore
|
1995-07-27 10:40:34 -07:00
|
|
|
(* Globals *)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pgetglobal of Ident.t
|
|
|
|
| Psetglobal of Ident.t
|
1995-07-27 10:40:34 -07:00
|
|
|
(* Operations on heap blocks *)
|
1995-11-09 05:22:16 -08:00
|
|
|
| Pmakeblock of int * mutable_flag
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pfield of int
|
1995-07-10 02:48:27 -07:00
|
|
|
| Psetfield of int * bool
|
1995-07-27 10:40:34 -07:00
|
|
|
| Pfloatfield of int
|
|
|
|
| Psetfloatfield of int
|
|
|
|
(* External call *)
|
|
|
|
| Pccall of Primitive.description
|
|
|
|
(* Exceptions *)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Praise
|
1995-07-27 10:40:34 -07:00
|
|
|
(* Boolean operations *)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Psequand | Psequor | Pnot
|
1995-07-27 10:40:34 -07:00
|
|
|
(* Integer operations *)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
|
|
|
|
| Pandint | Porint | Pxorint
|
|
|
|
| Plslint | Plsrint | Pasrint
|
1995-06-18 07:44:56 -07:00
|
|
|
| Pintcomp of comparison
|
1995-05-04 03:15:53 -07:00
|
|
|
| Poffsetint of int
|
|
|
|
| Poffsetref of int
|
1995-07-27 10:40:34 -07:00
|
|
|
(* Float operations *)
|
1995-07-11 01:53:14 -07:00
|
|
|
| Pintoffloat | Pfloatofint
|
1996-03-07 05:45:57 -08:00
|
|
|
| Pnegfloat | Pabsfloat
|
|
|
|
| Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
|
1995-06-18 07:44:56 -07:00
|
|
|
| Pfloatcomp of comparison
|
1995-07-27 10:40:34 -07:00
|
|
|
(* 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
|
1999-12-06 08:59:24 -08:00
|
|
|
(* Test if the argument is a block or an immediate integer *)
|
|
|
|
| Pisint
|
2000-10-02 07:18:05 -07:00
|
|
|
(* Test if the (integer) argument is outside an interval *)
|
|
|
|
| Pisout
|
1996-04-04 07:55:29 -08:00
|
|
|
(* Bitvect operations *)
|
|
|
|
| Pbittest
|
2000-02-21 10:14:56 -08:00
|
|
|
(* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
|
|
|
|
| Pbintofint of boxed_integer
|
|
|
|
| Pintofbint of boxed_integer
|
2000-03-05 11:17:54 -08:00
|
|
|
| Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
|
2000-02-21 10:14:56 -08:00
|
|
|
| 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
|
2000-02-28 07:45:50 -08:00
|
|
|
(* Operations on big arrays *)
|
|
|
|
| Pbigarrayref of int * bigarray_kind * bigarray_layout
|
|
|
|
| Pbigarrayset of int * bigarray_kind * bigarray_layout
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
and comparison =
|
|
|
|
Ceq | Cneq | Clt | Cgt | Cle | Cge
|
|
|
|
|
1995-07-27 10:40:34 -07:00
|
|
|
and array_kind =
|
|
|
|
Pgenarray | Paddrarray | Pintarray | Pfloatarray
|
|
|
|
|
2000-02-21 10:14:56 -08:00
|
|
|
and boxed_integer =
|
|
|
|
Pnativeint | Pint32 | Pint64
|
|
|
|
|
2000-02-28 07:45:50 -08:00
|
|
|
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
|
2002-02-10 09:01:27 -08:00
|
|
|
| Pbigarray_complex32 | Pbigarray_complex64
|
2000-02-28 07:45:50 -08:00
|
|
|
|
|
|
|
and bigarray_layout =
|
|
|
|
Pbigarray_unknown_layout
|
|
|
|
| Pbigarray_c_layout
|
|
|
|
| Pbigarray_fortran_layout
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
type structured_constant =
|
|
|
|
Const_base of constant
|
1995-07-02 09:45:21 -07:00
|
|
|
| Const_pointer of int
|
1995-07-27 10:40:34 -07:00
|
|
|
| Const_block of int * structured_constant list
|
|
|
|
| Const_float_array of string list
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1996-10-22 06:36:59 -07:00
|
|
|
type function_kind = Curried | Tupled
|
|
|
|
|
1998-04-30 05:12:28 -07:00
|
|
|
type let_kind = Strict | Alias | StrictOpt | Variable
|
|
|
|
(* Meaning of kinds for let x = e in e':
|
|
|
|
Strict: e may have side-effets; always evaluate e first
|
|
|
|
(If e is a simple expression, e.g. a variable or constant,
|
|
|
|
we may still substitute e'[x/e].)
|
|
|
|
Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
|
|
|
|
in e'
|
|
|
|
StrictOpt: e does not have side-effects, but depend on the store;
|
|
|
|
we can discard e if x does not appear in e'
|
|
|
|
Variable: the variable x is assigned later in e' *)
|
1996-04-22 04:15:41 -07:00
|
|
|
|
|
|
|
type shared_code = (int * int) list (* stack size -> code label *)
|
1995-12-15 02:18:29 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
type lambda =
|
|
|
|
Lvar of Ident.t
|
|
|
|
| Lconst of structured_constant
|
|
|
|
| Lapply of lambda * lambda list
|
1996-10-22 06:36:59 -07:00
|
|
|
| Lfunction of function_kind * Ident.t list * lambda
|
1995-12-15 02:18:29 -08:00
|
|
|
| Llet of let_kind * Ident.t * lambda * lambda
|
1995-07-02 09:45:21 -07:00
|
|
|
| Lletrec of (Ident.t * lambda) list * lambda
|
1995-05-04 03:15:53 -07:00
|
|
|
| Lprim of primitive * lambda list
|
1996-04-04 07:55:29 -08:00
|
|
|
| Lswitch of lambda * lambda_switch
|
2000-10-02 07:18:05 -07:00
|
|
|
| Lstaticraise of int * lambda list
|
|
|
|
| Lstaticcatch of lambda * (int * Ident.t list) * lambda
|
1995-05-04 03:15:53 -07:00
|
|
|
| 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
|
1995-11-25 07:38:43 -08:00
|
|
|
| Lassign of Ident.t * lambda
|
1996-04-22 04:15:41 -07:00
|
|
|
| Lsend of lambda * lambda * lambda list
|
1996-11-29 10:36:42 -08:00
|
|
|
| Levent of lambda * lambda_event
|
1998-06-24 12:22:26 -07:00
|
|
|
| Lifused of Ident.t * lambda
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1996-04-04 07:55:29 -08:00
|
|
|
and lambda_switch =
|
|
|
|
{ sw_numconsts: int; (* Number of integer cases *)
|
|
|
|
sw_consts: (int * lambda) list; (* Integer cases *)
|
|
|
|
sw_numblocks: int; (* Number of tag block cases *)
|
|
|
|
sw_blocks: (int * lambda) list; (* Tag block cases *)
|
2001-02-19 12:27:52 -08:00
|
|
|
sw_failaction : lambda option} (* Action to take if failure *)
|
1996-11-29 10:36:42 -08:00
|
|
|
and lambda_event =
|
2002-11-01 09:06:47 -08:00
|
|
|
{ lev_pos: Lexing.position;
|
1996-11-29 10:36:42 -08:00
|
|
|
lev_kind: lambda_event_kind;
|
1997-03-27 12:53:30 -08:00
|
|
|
lev_repr: int ref option;
|
1996-11-29 10:36:42 -08:00
|
|
|
lev_env: Env.summary }
|
|
|
|
|
|
|
|
and lambda_event_kind =
|
|
|
|
Lev_before
|
|
|
|
| Lev_after of Types.type_expr
|
1997-03-27 12:53:30 -08:00
|
|
|
| Lev_function
|
1996-11-29 10:36:42 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
val const_unit: structured_constant
|
|
|
|
val lambda_unit: lambda
|
|
|
|
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
|
1995-07-02 09:45:21 -07:00
|
|
|
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
|
1995-05-04 03:15:53 -07:00
|
|
|
val is_guarded: lambda -> bool
|
2001-02-19 12:27:52 -08:00
|
|
|
val patch_guarded : lambda -> lambda -> lambda
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1995-10-03 07:03:30 -07:00
|
|
|
module IdentSet: Set.S with type elt = Ident.t
|
1995-07-02 09:45:21 -07:00
|
|
|
val free_variables: lambda -> IdentSet.t
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
val transl_path: Path.t -> lambda
|
1999-02-04 02:31:16 -08:00
|
|
|
val make_sequence: ('a -> lambda) -> 'a list -> lambda
|
|
|
|
|
|
|
|
val subst_lambda: lambda Ident.tbl -> lambda -> lambda
|
2000-10-02 07:18:05 -07:00
|
|
|
val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
|
|
|
|
|
|
|
|
val commute_comparison : comparison -> comparison
|
|
|
|
val negate_comparison : comparison -> comparison
|
|
|
|
|
2001-02-19 12:27:52 -08:00
|
|
|
(***********************)
|
|
|
|
(* For static failures *)
|
|
|
|
(***********************)
|
|
|
|
|
|
|
|
(* Get a new static failure ident *)
|
2000-10-02 07:18:05 -07:00
|
|
|
val next_raise_count : unit -> int
|
2001-02-19 12:27:52 -08:00
|
|
|
|
|
|
|
|
|
|
|
val staticfail : lambda (* Anticipated static failure *)
|
|
|
|
|
|
|
|
(* Check anticipated failure, substitute its final value *)
|
|
|
|
val is_guarded: lambda -> bool
|
|
|
|
val patch_guarded : lambda -> lambda -> lambda
|
|
|
|
|