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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id: typeopt.ml 10506 2010-06-04 19:16:52Z maranget $ *)
(* Auxiliaries for type-based optimizations, e.g. array kinds *)
open Misc
open Asttypes
open Primitive
open Path
open Types
open Typedtree
open Lambda
let scrape env ty =
(Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc
let has_base_type exp base_ty_path =
match scrape exp.exp_env exp.exp_type with
| Tconstr(p, _, _) -> Path.same p base_ty_path
| _ -> false
let maybe_pointer exp =
match scrape exp.exp_env exp.exp_type with
| Tconstr(p, args, abbrev) ->
not (Path.same p Predef.path_int) &&
not (Path.same p Predef.path_char) &&
begin try
match Env.find_type p exp.exp_env with
{type_kind = Type_variant []} -> true (* type exn *)
| {type_kind = Type_variant cstrs} ->
List.exists (fun (name, args) -> args <> []) cstrs
| _ -> true
with Not_found -> true
(* This can happen due to e.g. missing -I options,
causing some .cmi files to be unavailable.
Maybe we should emit a warning. *)
end
| _ -> true
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 (name, args) -> args = []) 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_kind_gen ty env =
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_kind_gen exp.exp_type exp.exp_env
let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env
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_kind_and_layout exp =
match scrape exp.exp_env exp.exp_type with
| Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
(bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown,
bigarray_decode_type exp.exp_env layout_type layout_table Pbigarray_unknown_layout)
| _ ->
(Pbigarray_unknown, Pbigarray_unknown_layout)
let is_unit_channel_type ty env =
let channel_ty =Ctype.repr (Ctype.expand_head_opt env ty) in
match channel_ty.desc with
| Tconstr(p, [msg_ty], _)
(* when Path.same p Predef.path_channel *) ->
let msg_ty = Ctype.repr (Ctype.expand_head_opt env msg_ty) in
begin match msg_ty.desc with
| Tconstr (p,[],_) when Path.same p Predef.path_unit -> true
| _ -> false
end
| _ ->
(* This can happen with synchronous channels *)
false
|
