@@ -11,10 +11,89 @@ type number =
11
11
| Nativeint
12
12
| Float
13
13
14
+ module Bigarray = struct
15
+ type kind =
16
+ | Float32
17
+ | Float64
18
+ | Int8_signed
19
+ | Int8_unsigned
20
+ | Int16_signed
21
+ | Int16_unsigned
22
+ | Int32
23
+ | Int64
24
+ | Int
25
+ | Nativeint
26
+ | Complex32
27
+ | Complex64
28
+ | Char
29
+ | Float16
30
+
31
+ type layout =
32
+ | C
33
+ | Fortran
34
+
35
+ type t =
36
+ { kind : kind
37
+ ; layout : layout
38
+ }
39
+
40
+ let make ~kind ~layout =
41
+ { kind =
42
+ (match kind with
43
+ | 0 -> Float32
44
+ | 1 -> Float64
45
+ | 2 -> Int8_signed
46
+ | 3 -> Int8_unsigned
47
+ | 4 -> Int16_signed
48
+ | 5 -> Int16_unsigned
49
+ | 6 -> Int32
50
+ | 7 -> Int64
51
+ | 8 -> Int
52
+ | 9 -> Nativeint
53
+ | 10 -> Complex32
54
+ | 11 -> Complex64
55
+ | 12 -> Char
56
+ | 13 -> Float16
57
+ | _ -> assert false )
58
+ ; layout =
59
+ (match layout with
60
+ | 0 -> C
61
+ | 1 -> Fortran
62
+ | _ -> assert false )
63
+ }
64
+
65
+ let print f { kind; layout } =
66
+ Format. fprintf
67
+ f
68
+ " bigarray{%s,%s}"
69
+ (match kind with
70
+ | Float32 -> " float32"
71
+ | Float64 -> " float64"
72
+ | Int8_signed -> " sint8"
73
+ | Int8_unsigned -> " uint8"
74
+ | Int16_signed -> " sint16"
75
+ | Int16_unsigned -> " uint16"
76
+ | Int32 -> " int32"
77
+ | Int64 -> " int64"
78
+ | Int -> " int"
79
+ | Nativeint -> " nativeint"
80
+ | Complex32 -> " complex32"
81
+ | Complex64 -> " complex64"
82
+ | Char -> " char"
83
+ | Float16 -> " float16" )
84
+ (match layout with
85
+ | C -> " C"
86
+ | Fortran -> " Fortran" )
87
+
88
+ let equal { kind; layout } { kind = kind' ; layout = layout' } =
89
+ phys_equal kind kind' && phys_equal layout layout'
90
+ end
91
+
14
92
type typ =
15
93
| Top
16
94
| Number of number
17
95
| Tuple of typ array
96
+ | Bigarray of Bigarray .t
18
97
| Bot
19
98
20
99
module Domain = struct
@@ -25,9 +104,17 @@ module Domain = struct
25
104
| Bot , t | t , Bot -> t
26
105
| Number n , Number n' -> if Poly. equal n n' then t else Top
27
106
| Tuple t , Tuple t' ->
28
- if Array. length t = Array. length t' then Tuple (Array. map2 ~f: join t t') else Top
107
+ let l = Array. length t in
108
+ let l' = Array. length t' in
109
+ Tuple
110
+ (if l = l'
111
+ then Array. map2 ~f: join t t'
112
+ else
113
+ Array. init (max l l') ~f: (fun i ->
114
+ if i < l then if i < l' then join t.(i) t'.(i) else t.(i) else t'.(i)))
115
+ | Bigarray b , Bigarray b' when Bigarray. equal b b' -> t
29
116
| Top , _ | _ , Top -> Top
30
- | Number _ , Tuple _ | Tuple _ , Number _ -> Top
117
+ | ( Number _ | Tuple _ | Bigarray _ ), _ -> Top
31
118
32
119
let join_set ?(others = false ) f s =
33
120
if others then Top else Var.Set. fold (fun x a -> join (f x) a) s Bot
@@ -38,7 +125,8 @@ module Domain = struct
38
125
| Number t , Number t' -> Poly. equal t t'
39
126
| Tuple t , Tuple t' ->
40
127
Array. length t = Array. length t' && Array. for_all2 ~f: equal t t'
41
- | (Top | Tuple _ | Number _ | Bot ), _ -> false
128
+ | Bigarray b , Bigarray b' -> Bigarray. equal b b'
129
+ | (Top | Tuple _ | Number _ | Bigarray _ | Bot ), _ -> false
42
130
43
131
let bot = Bot
44
132
@@ -47,8 +135,15 @@ module Domain = struct
47
135
| _ , Top | Bot , _ -> true
48
136
| Top , _ | _ , Bot -> false
49
137
| Number t , Number t' -> Poly. equal t t'
50
- | Tuple t , Tuple t' -> Array. length t = Array. length t' && Array. for_all2 ~f: sub t t'
51
- | Number _ , _ | Tuple _ , _ -> false
138
+ | Tuple t , Tuple t' ->
139
+ Array. length t < = Array. length t'
140
+ &&
141
+ let rec compare t t' i l =
142
+ i = l || (sub t.(i) t'.(i) && compare t t' (i + 1 ) l)
143
+ in
144
+ compare t t' 0 (Array. length t)
145
+ | Bigarray b , Bigarray b' -> Bigarray. equal b b'
146
+ | (Number _ | Tuple _ | Bigarray _ ), _ -> false
52
147
53
148
let rec print f t =
54
149
match t with
@@ -59,12 +154,30 @@ module Domain = struct
59
154
| Number Int64 -> Format. fprintf f " int64"
60
155
| Number Nativeint -> Format. fprintf f " nativeint"
61
156
| Number Float -> Format. fprintf f " float"
157
+ | Bigarray b -> Bigarray. print f b
62
158
| Tuple t ->
63
159
Format. fprintf
64
160
f
65
161
" (%a)"
66
162
(Format. pp_print_array ~pp_sep: (fun f () -> Format. fprintf f " ," ) print)
67
163
t
164
+
165
+ let depth_treshold = 4
166
+
167
+ let rec depth t =
168
+ match t with
169
+ | Top | Bot | Number _ | Bigarray _ -> 0
170
+ | Tuple l -> 1 + Array. fold_left ~f: (fun acc t' -> max (depth t') acc) l ~init: 0
171
+
172
+ let rec truncate depth t =
173
+ match t with
174
+ | Top | Bot | Number _ | Bigarray _ -> t
175
+ | Tuple l ->
176
+ if depth = 0
177
+ then Top
178
+ else Tuple (Array. map ~f: (fun t' -> truncate (depth - 1 ) t') l)
179
+
180
+ let limit t = if depth t > depth_treshold then truncate depth_treshold t else t
68
181
end
69
182
70
183
let update_deps st { blocks; _ } =
@@ -268,7 +381,7 @@ let propagate st approx x : Domain.t =
268
381
match st.state.mutable_fields.(Var. idx x) with
269
382
| All_fields -> Top
270
383
| Some_fields s when IntSet. mem i s -> Top
271
- | Some_fields _ | No_field -> Var.Tbl. get approx y)
384
+ | Some_fields _ | No_field -> Domain. limit ( Var.Tbl. get approx y) )
272
385
lst)
273
386
| Field (y , n , _ ) -> (
274
387
match Var.Tbl. get approx y with
@@ -316,7 +429,32 @@ let propagate st approx x : Domain.t =
316
429
| Expr (Closure (params, _, _))
317
430
when List. length args = List. length params ->
318
431
Domain. join_set
319
- (fun y -> Var.Tbl. get approx y)
432
+ (fun y ->
433
+ match st.state.defs.(Var. idx y) with
434
+ | Expr
435
+ (Prim (Extern " caml_ba_create" , [ Pv kind; Pv layout; _ ]))
436
+ -> (
437
+ let m =
438
+ List. fold_left2
439
+ ~f: (fun m p a -> Var.Map. add p a m)
440
+ ~init: Var.Map. empty
441
+ params
442
+ args
443
+ in
444
+ try
445
+ match
446
+ ( st.state.defs.(Var. idx (Var.Map. find kind m))
447
+ , st.state.defs.(Var. idx (Var.Map. find layout m)) )
448
+ with
449
+ | Expr (Constant (Int kind)), Expr (Constant (Int layout))
450
+ ->
451
+ Bigarray
452
+ (Bigarray. make
453
+ ~kind: (Targetint. to_int_exn kind)
454
+ ~layout: (Targetint. to_int_exn layout))
455
+ | _ -> raise Not_found
456
+ with Not_found -> Var.Tbl. get approx y)
457
+ | _ -> Var.Tbl. get approx y)
320
458
(Var.Map. find g st.state.return_values)
321
459
| Expr (Closure (_ , _ , _ )) ->
322
460
(* The function is partially applied or over applied *)
@@ -368,6 +506,10 @@ let print_opt typ f e =
368
506
l)
369
507
[ Number Int ; Number Int32 ; Number Int64 ; Number Nativeint ; Number Float ]
370
508
then Format. fprintf f " OPT"
509
+ | Prim (Extern ("caml_ba_get_1" | "caml_ba_set_1" ), Pv x :: _ ) -> (
510
+ match Var.Tbl. get typ x with
511
+ | Bigarray _ -> Format. fprintf f " OPT"
512
+ | _ -> () )
371
513
| _ -> ()
372
514
373
515
let f ~state ~info p =
0 commit comments