1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Auxiliaries for type-based optimizations, e.g. array kinds *)
open Path
open Types
open Typedtree
open Lambda
let scrape env ty =
match
(Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc
with
| Tconstr (p, _, _) as desc ->
begin match Env.find_type p env with
| {type_unboxed = {unboxed = true; _}; _} ->
begin match Typedecl.get_unboxed_type_representation env ty with
| None -> desc
| Some ty2 -> ty2.desc
end
| _ -> desc
| exception Not_found -> desc
end
| desc -> desc
let is_function_type env ty =
match scrape env ty with
| Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs)
| _ -> None
let is_base_type env ty base_ty_path =
match scrape env ty with
| Tconstr(p, _, _) -> Path.same p base_ty_path
| _ -> false
let has_base_type exp base_ty_path =
is_base_type exp.exp_env exp.exp_type base_ty_path
let maybe_pointer_type env ty =
if Ctype.maybe_pointer_type env ty then
Pointer
else
Immediate
let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
let array_element_kind env ty =
match scrape env ty with
| Tvar _ | Tunivar _ ->
Pgenarray
| Tconstr(p, _args, _abbrev) ->
if Path.same p Predef.path_int || Path.same p Predef.path_char then
Pintarray
else if Path.same p Predef.path_float then
Pfloatarray
else if Path.same p Predef.path_string
|| Path.same p Predef.path_array
|| Path.same p Predef.path_nativeint
|| Path.same p Predef.path_int32
|| Path.same p Predef.path_int64 then
Paddrarray
else begin
try
match Env.find_type p env with
{type_kind = Type_abstract} ->
Pgenarray
| {type_kind = Type_variant cstrs}
when List.for_all (fun c -> c.Types.cd_args = Types.Cstr_tuple [])
cstrs ->
Pintarray
| {type_kind = _} ->
Paddrarray
with Not_found ->
(* This can happen due to e.g. missing -I options,
causing some .cmi files to be unavailable.
Maybe we should emit a warning. *)
Pgenarray
end
| _ ->
Paddrarray
let array_type_kind env ty =
match scrape env ty with
| Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
when Path.same p Predef.path_array ->
array_element_kind env elt_ty
| _ ->
(* This can happen with e.g. Obj.field *)
Pgenarray
let array_kind exp = array_type_kind exp.exp_env exp.exp_type
let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type
let bigarray_decode_type env ty tbl dfl =
match scrape env ty with
| Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
when Ident.name mod_id = "Bigarray" ->
begin try List.assoc type_name tbl with Not_found -> dfl end
| _ ->
dfl
let kind_table =
["float32_elt", Pbigarray_float32;
"float64_elt", Pbigarray_float64;
"int8_signed_elt", Pbigarray_sint8;
"int8_unsigned_elt", Pbigarray_uint8;
"int16_signed_elt", Pbigarray_sint16;
"int16_unsigned_elt", Pbigarray_uint16;
"int32_elt", Pbigarray_int32;
"int64_elt", Pbigarray_int64;
"int_elt", Pbigarray_caml_int;
"nativeint_elt", Pbigarray_native_int;
"complex32_elt", Pbigarray_complex32;
"complex64_elt", Pbigarray_complex64]
let layout_table =
["c_layout", Pbigarray_c_layout;
"fortran_layout", Pbigarray_fortran_layout]
let bigarray_type_kind_and_layout env typ =
match scrape env typ with
| Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
(bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
bigarray_decode_type env layout_type layout_table
Pbigarray_unknown_layout)
| _ ->
(Pbigarray_unknown, Pbigarray_unknown_layout)
let value_kind env ty =
match scrape env ty with
| Tconstr(p, _, _) when Path.same p Predef.path_int ->
Pintval
| Tconstr(p, _, _) when Path.same p Predef.path_char ->
Pintval
| Tconstr(p, _, _) when Path.same p Predef.path_float ->
Pfloatval
| Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
Pboxedintval Pint32
| Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
Pboxedintval Pint64
| Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
Pboxedintval Pnativeint
| _ ->
Pgenval
|
