diff --git a/src/compile.ml b/src/compile.ml index 07de524678b..f23aee91997 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1361,10 +1361,12 @@ module Prim = struct prim_word32toInt let prim_intToWord32 = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) - let prim_shiftToWordN b = - prim_intToWord32 ^^ + let prim_shift_leftWordNtoI32 b = compile_unboxed_const b ^^ G.i (Binary (I32 I32Op.Shl)) + let prim_shiftToWordN b = + prim_intToWord32 ^^ + prim_shift_leftWordNtoI32 b end (* Prim *) module Object = struct @@ -3384,12 +3386,23 @@ let lsb_adjust = function | Type.Word32 -> G.nop | ty -> Prim.prim_shiftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) +(* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) +let msb_adjust = function + | Type.Word32 -> G.nop + | ty -> Prim.prim_shift_leftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) + (* Makes sure that the word representation invariant is restored. *) let sanitize_word_result = function | Type.Word32 -> G.nop | ty -> compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ G.i (Binary (Wasm.Values.I32 I32Op.And)) +(* Makes sure that the word representation invariant is restored. *) +let compile_word_padding = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (UnboxedSmallWord.padding_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) + (* This returns a single StackRep, to be used for both arguments and the result. One could imagine operators that require or produce different StackReps, but none of these do, so a single value is fine. @@ -3597,6 +3610,12 @@ and compile_exp (env : E.t) exp = in match p with | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) + | "shrs8" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word8 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word8) + | "shrs16" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word16 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word16) | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) @@ -3680,6 +3699,12 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | "popcnt8" + | "popcnt16" -> + SR.Vanilla, + compile_exp_vanilla env e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ + msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) | "popcnt64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ @@ -3688,6 +3713,14 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "clz8" + | "clz16" -> + SR.Vanilla, + let ty = match p with | "clz8" -> Type.Word8 | _ -> Type.Word16 + in compile_exp_vanilla env e ^^ + compile_word_padding ty ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^ + msb_adjust ty | "clz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ @@ -3696,6 +3729,16 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | "ctz8" + | "ctz16" -> + SR.Vanilla, + let ty = match p with | "ctz8" -> Type.Word8 | _ -> Type.Word16 + in compile_exp_vanilla env e ^^ + compile_word_padding ty ^^ + compile_unboxed_const (UnboxedSmallWord.shift_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^ + msb_adjust ty | "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ diff --git a/src/prelude.ml b/src/prelude.ml index ef9b6ea5b8c..46eb20bc132 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -59,6 +59,16 @@ func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; // Exotic bitwise operations +func shrsWord8(w : Word8, amount : Word8) : Word8 = (prim "shrs8" : (Word8, Word8) -> Word8) (w, amount); +func popcntWord8(w : Word8) : Word8 = (prim "popcnt8" : Word8 -> Word8) w; +func clzWord8(w : Word8) : Word8 = (prim "clz8" : Word8 -> Word8) w; +func ctzWord8(w : Word8) : Word8 = (prim "ctz8" : Word8 -> Word8) w; + +func shrsWord16(w : Word16, amount : Word16) : Word16 = (prim "shrs16" : (Word16, Word16) -> Word16) (w, amount); +func popcntWord16(w : Word16) : Word16 = (prim "popcnt16" : Word16 -> Word16) w; +func clzWord16(w : Word16) : Word16 = (prim "clz16" : Word16 -> Word16) w; +func ctzWord16(w : Word16) : Word16 = (prim "ctz16" : Word16 -> Word16) w; + func shrsWord32(w : Word32, amount : Word32) : Word32 = (prim "shrs" : (Word32, Word32) -> Word32) (w, amount); func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; @@ -178,32 +188,48 @@ let prim = function | "Word32->Char" -> fun v k -> let i = Conv.of_signed_Word32 (as_word32 v) in k (Char i) - | "shrs" -> fun v k -> - let w, a = as_pair v in - let i = Word32.shr_s (as_word32 w) (as_word32 a) - in k (Word32 i) + | "shrs8" + | "shrs16" + | "shrs" | "shrs64" -> fun v k -> - let w, a = as_pair v in - let i = Word64.shr_s (as_word64 w) (as_word64 a) - in k (Word64 i) - | "popcnt" -> fun v k -> - let i = Word32.popcnt (as_word32 v) - in k (Word32 i) + let w, a = as_pair v + in k (match w with + | Word8 y -> Word8 (Word8 .shr_s y (as_word8 a)) + | Word16 y -> Word16 (Word16.shr_s y (as_word16 a)) + | Word32 y -> Word32 (Word32.shr_s y (as_word32 a)) + | Word64 y -> Word64 (Word64.shr_s y (as_word64 a)) + | _ -> failwith "shrs") + | "popcnt8" + | "popcnt16" + | "popcnt" | "popcnt64" -> fun v k -> - let i = Word64.popcnt (as_word64 v) - in k (Word64 i) - | "clz" -> fun v k -> - let i = Word32.clz (as_word32 v) - in k (Word32 i) + k (match v with + | Word8 w -> Word8 (Word8. popcnt w) + | Word16 w -> Word16 (Word16.popcnt w) + | Word32 w -> Word32 (Word32.popcnt w) + | Word64 w -> Word64 (Word64.popcnt w) + | _ -> failwith "popcnt") + | "clz8" + | "clz16" + | "clz" | "clz64" -> fun v k -> - let i = Word64.clz (as_word64 v) - in k (Word64 i) - | "ctz" -> fun v k -> - let i = Word32.ctz (as_word32 v) - in k (Word32 i) + k (match v with + | Word8 w -> Word8 (Word8. clz w) + | Word16 w -> Word16 (Word16.clz w) + | Word32 w -> Word32 (Word32.clz w) + | Word64 w -> Word64 (Word64.clz w) + | _ -> failwith "clz") + | "ctz8" + | "ctz16" + | "ctz" | "ctz64" -> fun v k -> - let i = Word64.ctz (as_word64 v) - in k (Word64 i) + k (match v with + | Word8 w -> Word8 (Word8. ctz w) + | Word16 w -> Word16 (Word16.ctz w) + | Word32 w -> Word32 (Word32.ctz w) + | Word64 w -> Word64 (Word64.ctz w) + | _ -> failwith "ctz") + | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit | "Array.init" -> fun v k -> diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/words.as b/test/run/words.as index 30179b9091b..a6a2cd0128a 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -162,7 +162,7 @@ func checkpointJuliett() {}; // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW16ln printW16ln(a >> b); - // printW16ln(shrs d b); // TODO(Gabor) + printW16ln(shrsWord16(d, 3 : Word16)); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (shifted = 0b1111_1111_1111_1110 = -2) // CHECK: call $checkpointFoxtrot checkpointFoxtrot(); @@ -177,9 +177,9 @@ func checkpointJuliett() {}; // CHECK-NEXT: call $rotr // CHECK-NEXT: call $printW16ln printW16ln(c <>> b); - // printW16ln(popcnt d); // TODO(Gabor) - // printW16ln(clz c); // TODO(Gabor) - // printW16ln(ctz e); // TODO(Gabor) + printW16ln(popcntWord16 d); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (population = 13) + printW16ln(clzWord16 e); // 20000 = 0x4e20 (leading zeros = 1) + printW16ln(ctzWord16 e); // 20000 = 0x4e20 (trailing zeros = 5) assert (3 : Word16 ** (0 : Word16) == (1 : Word16)); @@ -236,7 +236,7 @@ func checkpointJuliett() {}; // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW8ln printW8ln(a >> b); - // printW8ln(shrs d b); // TODO(Gabor) + printW8ln(shrsWord8(d, 3 : Word8)); // -15 = 0xf1 = 0b1111_0001 (shifted = 0b1111_1110 = -2) // CHECK: call $checkpointJuliett checkpointJuliett(); @@ -248,9 +248,9 @@ func checkpointJuliett() {}; // CHECK-NEXT: call $rotr // CHECK-NEXT: call $printW8ln printW8ln(c <>> b); - // printW8ln(popcnt d); // TODO(Gabor) - // printW8ln(clz c); // TODO(Gabor) - // printW8ln(ctz e); // TODO(Gabor) + printW8ln(popcntWord8 d); // -15 = 0xf1 = 0b1111_0001 (population = 5) + printW8ln(clzWord8 e); // 200 = 0xC8 (leading zeros = 0) + printW8ln(ctzWord8 e); // 200 = 0xC8 (trailing zeros = 3) assert (3 : Word8 ** (0 : Word8) == (1 : Word8)); assert (3 : Word8 ** (3 : Word8) == (27 : Word8));