Skip to content

Commit 8bd8126

Browse files
vouillonvouillon
committed
WIP
1 parent 9b5c73f commit 8bd8126

File tree

4 files changed

+216
-66
lines changed

4 files changed

+216
-66
lines changed

‎compiler/lib-wasm/gc_target.ml

Lines changed: 71 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1387,49 +1387,85 @@ module Math = struct
13871387
end
13881388

13891389
module Bigarray = struct
1390-
let dim1 a =
1390+
let dim n a =
13911391
let* ty = Type.bigarray_type in
13921392
Memory.wasm_array_get
13931393
~ty:Type.int_array_type
13941394
(Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 3)
1395-
(Arith.const 0l)
1395+
(Arith.const (Int32.of_int n))
13961396

13971397
let get ~kind a i =
1398-
match kind with
1399-
| Typing.Bigarray.Int8_unsigned | Char ->
1400-
let* f =
1401-
register_import
1402-
~import_module:"bindings"
1403-
~name:"dv_get_ui8"
1404-
(Fun
1405-
{ W.params = [ Ref { nullable = false; typ = Extern }; I32 ]
1406-
; result = [ I32 ]
1407-
})
1408-
in
1409-
let* ty = Type.bigarray_type in
1410-
let* ta = Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 2 in
1411-
let* i = i in
1412-
return (W.Call (f, [ ta; i ]))
1413-
| _ -> assert false
1398+
let name, (typ : Wasm_ast.value_type), size, box =
1399+
match (kind : Typing.Bigarray.kind) with
1400+
| Float32 ->
1401+
(*ZZZ*)
1402+
( "dv_get_f32"
1403+
, F32
1404+
, 2
1405+
, fun x ->
1406+
let* x = x in
1407+
Memory.box_float (return (W.F64PromoteF32 x)) )
1408+
| Float64 -> "dv_get_f64", F64, 3, Memory.box_float
1409+
| Int8_signed -> "dv_get_i8", I32, 2, Fun.id
1410+
| Int8_unsigned | Char -> "dv_get_ui8", I32, 2, Fun.id
1411+
| Int16_signed -> "dv_get_i16", I32, 2, Fun.id
1412+
| Int16_unsigned -> "dv_get_ui16", I32, 2, Fun.id
1413+
| Int32 -> "dv_get_i32", I32, 2, Memory.box_int32
1414+
| Nativeint -> "dv_get_i32", I32, 2, Memory.box_nativeint
1415+
| Int64 -> "dv_get_i64", I64, 3, Memory.box_int64
1416+
| Int -> "dv_get_i32", I32, 2, Fun.id
1417+
| Complex32 | Complex64 | Float16 -> assert false (*ZZZ*)
1418+
in
1419+
let* f =
1420+
register_import
1421+
~import_module:"bindings"
1422+
~name
1423+
(Fun
1424+
{ W.params = [ Ref { nullable = false; typ = Extern }; I32 ]
1425+
; result = [ typ ]
1426+
})
1427+
in
1428+
let* ty = Type.bigarray_type in
1429+
let* ta = Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 2 in
1430+
let* i = if size = 1 then i else Arith.(i lsl const (Int32.of_int size)) in
1431+
box (return (W.Call (f, [ ta; i ])))
14141432

14151433
let set ~kind a i v =
1416-
match kind with
1417-
| Typing.Bigarray.Int8_unsigned | Char ->
1418-
let* f =
1419-
register_import
1420-
~import_module:"bindings"
1421-
~name:"dv_set_ui8"
1422-
(Fun
1423-
{ W.params = [ Ref { nullable = false; typ = Extern }; I32; I32 ]
1424-
; result = []
1425-
})
1426-
in
1427-
let* ty = Type.bigarray_type in
1428-
let* ta = Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 2 in
1429-
let* i = i in
1430-
let* v = v in
1431-
instr (W.CallInstr (f, [ ta; i; v ]))
1432-
| _ -> assert false
1434+
let name, (typ : Wasm_ast.value_type), size, unbox =
1435+
match (kind : Typing.Bigarray.kind) with
1436+
| Float32 ->
1437+
(*ZZZ*)
1438+
( "dv_set_f32"
1439+
, F32
1440+
, 2
1441+
, fun x ->
1442+
let* e = Memory.unbox_float x in
1443+
return (W.F32DemoteF64 e) )
1444+
| Float64 -> "dv_set_f64", F64, 3, Memory.unbox_float
1445+
| Int8_signed -> "dv_set_i8", I32, 2, Fun.id
1446+
| Int8_unsigned | Char -> "dv_set_ui8", I32, 2, Fun.id
1447+
| Int16_signed -> "dv_set_i16", I32, 2, Fun.id
1448+
| Int16_unsigned -> "dv_set_ui16", I32, 2, Fun.id
1449+
| Int32 -> "dv_set_i32", I32, 2, Memory.unbox_int32
1450+
| Nativeint -> "dv_set_i32", I32, 2, Memory.unbox_nativeint
1451+
| Int64 -> "dv_set_i64", I64, 3, Memory.unbox_int64
1452+
| Int -> "dv_set_i32", I32, 2, Fun.id
1453+
| Complex32 | Complex64 | Float16 -> assert false (*ZZZ*)
1454+
in
1455+
let* ty = Type.bigarray_type in
1456+
let* ta = Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 2 in
1457+
let* i = if size = 1 then i else Arith.(i lsl const (Int32.of_int size)) in
1458+
let* v = unbox v in
1459+
let* f =
1460+
register_import
1461+
~import_module:"bindings"
1462+
~name
1463+
(Fun
1464+
{ W.params = [ Ref { nullable = false; typ = Extern }; I32; typ ]
1465+
; result = []
1466+
})
1467+
in
1468+
instr (W.CallInstr (f, [ ta; i; v ]))
14331469
end
14341470

14351471
module JavaScript = struct

‎compiler/lib-wasm/generate.ml

Lines changed: 142 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -887,45 +887,159 @@ module Generate (Target : Target_sig.S) = struct
887887
| _ -> invalid_arity "caml_compare" l ~expected:2);
888888
register_prim "caml_ba_get_1" `Mutator (fun ctx context l ->
889889
match l with
890-
| [ x; y ] -> (
891-
let x' = transl_prim_arg ctx x in
892-
match get_type ctx x with
893-
| Bigarray { kind = (Int8_unsigned | Char) as kind; layout = C } ->
894-
let y' = transl_prim_arg ctx ~typ:(Int Unnormalized) y in
890+
| [ ta; i ] -> (
891+
let ta' = transl_prim_arg ctx ta in
892+
match get_type ctx ta with
893+
| Bigarray { kind; layout = C } ->
894+
let i' = transl_prim_arg ctx ~typ:(Int Normalized) i in
895895
seq
896-
(let* cond = Arith.uge y' (Bigarray.dim1 x') in
896+
(let* cond = Arith.uge i' (Bigarray.dim 0 ta') in
897897
instr (W.Br_if (label_index context bound_error_pc, cond)))
898-
(Bigarray.get ~kind x' y')
898+
(Bigarray.get ~kind ta' i')
899899
| _ ->
900900
let* f =
901901
register_import ~name:"caml_ba_get_1" (Fun (Type.primitive_type 2))
902902
in
903-
let* x' = x' in
904-
let* y' = transl_prim_arg ctx y in
905-
return (W.Call (f, [ x'; y' ])))
903+
let* ta' = ta' in
904+
let* i' = transl_prim_arg ctx i in
905+
return (W.Call (f, [ ta'; i' ])))
906906
| _ -> invalid_arity "caml_ba_get_1" l ~expected:2);
907+
register_prim "caml_ba_get_2" `Mutator (fun ctx context l ->
908+
match l with
909+
| [ ta; i; j ] -> (
910+
let ta' = transl_prim_arg ctx ta in
911+
match get_type ctx ta with
912+
| Bigarray { kind; layout = C } ->
913+
let i' = transl_prim_arg ctx ~typ:(Int Normalized) i in
914+
let j' = transl_prim_arg ctx ~typ:(Int Normalized) j in
915+
seq
916+
(let* cond = Arith.uge i' (Bigarray.dim 0 ta') in
917+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
918+
let* cond = Arith.uge j' (Bigarray.dim 1 ta') in
919+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
920+
return ())
921+
(Bigarray.get ~kind ta' Arith.((i' * Bigarray.dim 0 ta') + j'))
922+
| _ ->
923+
let* f =
924+
register_import ~name:"caml_ba_get_2" (Fun (Type.primitive_type 3))
925+
in
926+
let* ta' = ta' in
927+
let* i' = transl_prim_arg ctx i in
928+
let* j' = transl_prim_arg ctx j in
929+
return (W.Call (f, [ ta'; i'; j' ])))
930+
| _ -> invalid_arity "caml_ba_get_1" l ~expected:3);
907931
register_prim "caml_ba_set_1" `Mutator (fun ctx context l ->
908932
match l with
909-
| [ x; y; z ] -> (
910-
let x' = transl_prim_arg ctx x in
911-
match get_type ctx x with
912-
| Bigarray { kind = (Int8_unsigned | Char) as kind; layout = C } ->
913-
let y' = transl_prim_arg ctx ~typ:(Int Normalized) y in
914-
let z' = transl_prim_arg ctx ~typ:(Int Unnormalized) z in
933+
| [ ta; i; v ] -> (
934+
let ta' = transl_prim_arg ctx ta in
935+
match get_type ctx ta with
936+
| Bigarray { kind; layout = C } ->
937+
let i' = transl_prim_arg ctx ~typ:(Int Normalized) i in
938+
let v' =
939+
transl_prim_arg
940+
ctx
941+
?typ:
942+
(match kind with
943+
| Int8_signed | Int8_unsigned | Int16_signed | Int16_unsigned | Char
944+
-> Some (Int Unnormalized)
945+
| Int -> Some (Int Normalized)
946+
| _ -> None)
947+
v
948+
in
915949
seq
916-
(let* cond = Arith.uge y' (Bigarray.dim1 x') in
950+
(let* cond = Arith.uge i' (Bigarray.dim 0 ta') in
917951
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
918-
Bigarray.set ~kind x' y' z')
952+
Bigarray.set ~kind ta' i' v')
919953
Value.unit
920954
| _ ->
921955
let* f =
922956
register_import ~name:"caml_ba_set_1" (Fun (Type.primitive_type 3))
923957
in
924-
let* x' = x' in
925-
let* y' = transl_prim_arg ctx y in
926-
let* z' = transl_prim_arg ctx z in
927-
return (W.Call (f, [ x'; y'; z' ])))
928-
| _ -> invalid_arity "caml_ba_set_1" l ~expected:3)
958+
let* ta' = ta' in
959+
let* i' = transl_prim_arg ctx i in
960+
let* v' = transl_prim_arg ctx v in
961+
return (W.Call (f, [ ta'; i'; v' ])))
962+
| _ -> invalid_arity "caml_ba_set_1" l ~expected:3);
963+
register_prim "caml_ba_set_2" `Mutator (fun ctx context l ->
964+
match l with
965+
| [ ta; i; j; v ] -> (
966+
let ta' = transl_prim_arg ctx ta in
967+
match get_type ctx ta with
968+
| Bigarray { kind; layout = C } ->
969+
let i' = transl_prim_arg ctx ~typ:(Int Normalized) i in
970+
let j' = transl_prim_arg ctx ~typ:(Int Normalized) j in
971+
let v' =
972+
transl_prim_arg
973+
ctx
974+
?typ:
975+
(match kind with
976+
| Int8_signed | Int8_unsigned | Int16_signed | Int16_unsigned | Char
977+
-> Some (Int Unnormalized)
978+
| Int -> Some (Int Normalized)
979+
| _ -> None)
980+
v
981+
in
982+
seq
983+
(let* cond = Arith.uge i' (Bigarray.dim 0 ta') in
984+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
985+
let* cond = Arith.uge j' (Bigarray.dim 1 ta') in
986+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
987+
Bigarray.set ~kind ta' Arith.((i' * Bigarray.dim 0 ta') + j') v')
988+
Value.unit
989+
| _ ->
990+
let* f =
991+
register_import ~name:"caml_ba_set_2" (Fun (Type.primitive_type 4))
992+
in
993+
let* ta' = ta' in
994+
let* i' = transl_prim_arg ctx i in
995+
let* j' = transl_prim_arg ctx j in
996+
let* v' = transl_prim_arg ctx v in
997+
return (W.Call (f, [ ta'; i'; j'; v' ])))
998+
| _ -> invalid_arity "caml_ba_set_2" l ~expected:4);
999+
register_prim "caml_ba_set_3" `Mutator (fun ctx context l ->
1000+
match l with
1001+
| [ ta; i; j; k; v ] -> (
1002+
let ta' = transl_prim_arg ctx ta in
1003+
match get_type ctx ta with
1004+
| Bigarray { kind; layout = C } ->
1005+
let i' = transl_prim_arg ctx ~typ:(Int Normalized) i in
1006+
let j' = transl_prim_arg ctx ~typ:(Int Normalized) j in
1007+
let k' = transl_prim_arg ctx ~typ:(Int Normalized) k in
1008+
let v' =
1009+
transl_prim_arg
1010+
ctx
1011+
?typ:
1012+
(match kind with
1013+
| Int8_signed | Int8_unsigned | Int16_signed | Int16_unsigned | Char
1014+
-> Some (Int Unnormalized)
1015+
| Int -> Some (Int Normalized)
1016+
| _ -> None)
1017+
v
1018+
in
1019+
seq
1020+
(let* cond = Arith.uge i' (Bigarray.dim 0 ta') in
1021+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
1022+
let* cond = Arith.uge j' (Bigarray.dim 1 ta') in
1023+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
1024+
let* cond = Arith.uge k' (Bigarray.dim 2 ta') in
1025+
let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in
1026+
Bigarray.set
1027+
~kind
1028+
ta'
1029+
Arith.((((i' * Bigarray.dim 0 ta') + j') * Bigarray.dim 1 ta') + k')
1030+
v')
1031+
Value.unit
1032+
| _ ->
1033+
let* f =
1034+
register_import ~name:"caml_ba_set_3" (Fun (Type.primitive_type 5))
1035+
in
1036+
let* ta' = ta' in
1037+
let* i' = transl_prim_arg ctx i in
1038+
let* j' = transl_prim_arg ctx j in
1039+
let* k' = transl_prim_arg ctx k in
1040+
let* v' = transl_prim_arg ctx v in
1041+
return (W.Call (f, [ ta'; i'; j'; k'; v' ])))
1042+
| _ -> invalid_arity "caml_ba_set_3" l ~expected:5)
9291043

9301044
let rec translate_expr ctx context x e =
9311045
match e with
@@ -1201,7 +1315,11 @@ module Generate (Target : Target_sig.S) = struct
12011315
| "caml_check_bound_gen"
12021316
| "caml_check_bound_float"
12031317
| "caml_ba_get_1"
1204-
| "caml_ba_set_1" )
1318+
| "caml_ba_get_2"
1319+
| "caml_ba_get_3"
1320+
| "caml_ba_set_1"
1321+
| "caml_ba_set_2"
1322+
| "caml_ba_set_3" )
12051323
, _ ) ) -> fst n, true
12061324
| Let
12071325
( _

‎compiler/lib-wasm/target_sig.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -254,7 +254,7 @@ module type S = sig
254254
end
255255

256256
module Bigarray : sig
257-
val dim1 : expression -> expression
257+
val dim : int -> expression -> expression
258258

259259
val get : kind:Typing.Bigarray.kind -> expression -> expression -> expression
260260

‎compiler/lib-wasm/typing.ml

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -443,14 +443,11 @@ let prim_type ~approx prim args =
443443
~kind:(Targetint.to_int_exn kind)
444444
~layout:(Targetint.to_int_exn layout))
445445
| _ -> Top)
446-
(*ZZZ *)
447-
| "caml_ba_get_1" (*| "caml_ba_get_2" | "caml_ba_get_3"*) -> (
446+
| "caml_ba_get_1" (*ZZZ | "caml_ba_get_2" | "caml_ba_get_3"*) -> (
448447
match args with
449448
| ba :: _ -> (
450449
match arg_type ~approx ba with
451450
| Bot -> Bot
452-
| Bigarray { kind = Int8_unsigned | Char; layout = C } -> Int Normalized
453-
(*ZZZ
454451
| Bigarray { kind; _ } -> (
455452
match kind with
456453
| Float16 | Float32 | Float64 -> Number Float
@@ -460,8 +457,7 @@ let prim_type ~approx prim args =
460457
| Int32 -> Number Int32
461458
| Int64 -> Number Int64
462459
| Nativeint -> Number Nativeint
463-
| Complex32 | Complex64 -> Tuple [Number Float; Number Float])
464-
*)
460+
| Complex32 | Complex64 -> Tuple [| Number Float; Number Float |])
465461
| _ -> Top)
466462
| [] -> Top)
467463
| _ -> Top

0 commit comments

Comments
 (0)