Skip to content

Move more useful functions into module UnboxedSmallWord #245

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
ggreif merged 6 commits into from
Mar 16, 2019
Merged

Move more useful functions into module UnboxedSmallWord #245

Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
bfcd2a6
Move more useful functions into module UnboxedSmallWord
nomeata Mar 15, 2019
c9b73c0
Merge remote-tracking branch 'origin/master' into joachim/UnboxedSmal…
ggreif Mar 16, 2019
a2e81d5
unclutter
ggreif Mar 16, 2019
0ec0a86
fix comment
ggreif Mar 16, 2019
fa19b95
factor out shrs and btst kernels
ggreif Mar 16, 2019
802d4ed
kernelise clz/ctz
ggreif Mar 16, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
200 changes: 93 additions & 107 deletions src/compile.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1328,6 +1328,70 @@ module UnboxedSmallWord = struct
| Wasm.Sexpr.Atom s -> seed ^ "<" ^ s ^ ">"
| wtf -> todo "name_of_type" wtf seed

(* Makes sure that we only shift/rotate the maximum number of bits available in the word. *)
let clamp_shift_amount = function
| Type.Word32 -> G.nop
| ty -> compile_unboxed_const (bitwidth_mask_of_type ty) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))

let shiftWordNtoI32 b =
compile_unboxed_const b ^^
G.i (Binary (Wasm.Values.I32 I32Op.ShrU))

let shift_leftWordNtoI32 b =
compile_unboxed_const b ^^
G.i (Binary (Wasm.Values.I32 I32Op.Shl))

(* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *)
let lsb_adjust = function
| Type.Word32 -> G.nop
| ty -> shiftWordNtoI32 (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 -> shift_leftWordNtoI32 (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 (mask_of_type ty) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))

(* Sets the number (according to the type's word invariant) of LSBs. *)
let compile_word_padding = function
| Type.Word32 -> G.nop
| ty -> compile_unboxed_const (padding_of_type ty) ^^
G.i (Binary (Wasm.Values.I32 I32Op.Or))

(* Kernel for counting leading zeros, according to the word invariant. *)
let clz_kernel ty =
compile_word_padding ty ^^
G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^
msb_adjust ty

(* Kernel for counting trailing zeros, according to the word invariant. *)
let ctz_kernel ty =
compile_word_padding ty ^^
compile_unboxed_const (shift_of_type ty) ^^
G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^
G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^
msb_adjust ty

(* Kernel for arithmetic (signed) shift, according to the word invariant. *)
let shrs_kernel ty =
lsb_adjust ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^
sanitize_word_result ty

(* Kernel for testing a bit position, according to the word invariant. *)
let btst_kernel env ty =
let (set_b, get_b) = new_local env "b"
in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^
compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))

end (* UnboxedSmallWord *)

(* Primitive functions *)
Expand Down Expand Up @@ -1362,11 +1426,8 @@ module Prim = struct
*)
let prim_word32toNat =
G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32))
let prim_shiftWordNtoI32 b =
compile_unboxed_const b ^^
G.i (Binary (I32 I32Op.ShrU))
let prim_shiftWordNtoUnsigned b =
prim_shiftWordNtoI32 b ^^
UnboxedSmallWord.shiftWordNtoI32 b ^^
prim_word32toNat
let prim_word32toInt =
G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32))
Expand All @@ -1376,12 +1437,9 @@ module Prim = struct
prim_word32toInt
let prim_intToWord32 =
G.i (Convert (Wasm.Values.I32 I32Op.WrapI64))
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
UnboxedSmallWord.shift_leftWordNtoI32 b
end (* Prim *)

module Object = struct
Expand Down Expand Up @@ -3439,33 +3497,6 @@ let compile_unop env t op = Syntax.(match op, t with
| _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable)
)

(* Makes sure that we only shift/rotate the maximum number of bits available in the word. *)
let clamp_shift_amount = function
| Type.Word32 -> G.nop
| ty -> compile_unboxed_const (UnboxedSmallWord.bitwidth_mask_of_type ty) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And))

(* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *)
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,
Expand All @@ -3491,7 +3522,7 @@ let rec compile_binop env t op =

| Type.Prim Type.(Word8 | Word16 | Word32), AddOp -> G.i (Binary (Wasm.Values.I32 I32Op.Add))
| Type.Prim Type.(Word8 | Word16 | Word32), SubOp -> G.i (Binary (Wasm.Values.I32 I32Op.Sub))
| Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> lsb_adjust ty ^^
| Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> UnboxedSmallWord.lsb_adjust ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.Mul))
| Type.Prim Type.(Word8 | Word16 | Word32), DivOp -> G.i (Binary (Wasm.Values.I32 I32Op.DivU))
| Type.Prim Type.(Word8 | Word16 | Word32), ModOp -> G.i (Binary (Wasm.Values.I32 I32Op.RemU))
Expand All @@ -3513,7 +3544,7 @@ let rec compile_binop env t op =
G.if_ (StackRep.to_block_type env SR.UnboxedWord32)
(square_recurse_with_shifted G.nop)
(get_n ^^
square_recurse_with_shifted (sanitize_word_result ty) ^^
square_recurse_with_shifted (UnboxedSmallWord.sanitize_word_result ty) ^^
mul)))
in pow ()
| Type.(Prim Int), PowOp ->
Expand Down Expand Up @@ -3552,31 +3583,31 @@ let rec compile_binop env t op =
| Type.(Prim Word64), XorOp -> G.i (Binary (Wasm.Values.I64 I64Op.Xor))
| Type.Prim Type.(Word8 | Word16 | Word32), XorOp -> G.i (Binary (Wasm.Values.I32 I32Op.Xor))
| Type.(Prim Word64), ShLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Shl))
| Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp ->
| Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> UnboxedSmallWord.(
lsb_adjust ty ^^ clamp_shift_amount ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.Shl))
G.i (Binary (Wasm.Values.I32 I32Op.Shl)))
| Type.(Prim Word64), ShROp -> G.i (Binary (Wasm.Values.I64 I64Op.ShrU))
| Type.(Prim (Word8|Word16|Word32 as ty)), ShROp ->
| Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> UnboxedSmallWord.(
lsb_adjust ty ^^ clamp_shift_amount ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^
sanitize_word_result ty
sanitize_word_result ty)
| Type.(Prim Word64), RotLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotl))
| Type.Prim Type. Word32, RotLOp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotl))
| Type.Prim Type.(Word8 | Word16 as ty), RotLOp ->
Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type]
| Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> UnboxedSmallWord.(
Func.share_code2 env (name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type]
Wasm.Values.(fun env get_n get_by ->
let beside_adjust = compile_unboxed_const (Int32.sub 32l (UnboxedSmallWord.shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in
let beside_adjust = compile_unboxed_const (Int32.sub 32l (shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in
get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^
get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^
sanitize_word_result ty)
sanitize_word_result ty))
| Type.(Prim Word64), RotROp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotr))
| Type.Prim Type. Word32, RotROp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotr))
| Type.Prim Type.(Word8 | Word16 as ty), RotROp ->
Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type]
| Type.Prim Type.(Word8 | Word16 as ty), RotROp -> UnboxedSmallWord.(
Func.share_code2 env (name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type]
Wasm.Values.(fun env get_n get_by ->
get_n ^^ get_n ^^ lsb_adjust ty ^^ G.i (Binary (I32 I32Op.Or)) ^^
get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotr)) ^^
sanitize_word_result ty)
sanitize_word_result ty))

| Type.Prim Type.Text, CatOp -> Text.concat env
| _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable)
Expand Down Expand Up @@ -3760,45 +3791,19 @@ and compile_exp (env : E.t) exp =
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)
UnboxedSmallWord.msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16)
| "popcnt64" ->
SR.UnboxedInt64,
compile_exp_as env SR.UnboxedInt64 e ^^
G.i (Unary (Wasm.Values.I64 I64Op.Popcnt))
| "clz" ->
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 ^^
G.i (Unary (Wasm.Values.I64 I64Op.Clz))
| "ctz" ->
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 ^^
G.i (Unary (Wasm.Values.I64 I64Op.Ctz))
| "clz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz))
| "clz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word8
| "clz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word16
| "clz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Clz))
| "ctz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz))
| "ctz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word8
| "ctz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word16
| "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz))

| "printInt" ->
SR.unit,
Expand All @@ -3817,32 +3822,13 @@ 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)
| "shrs8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel Type.Word8)
| "shrs16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel 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)))
| "btst8" -> compile_kernel_as SR.Vanilla (
let ty = Type.Word8 in
let (set_b, get_b) = new_local env "b"
in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^
compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And)))
| "btst16" -> compile_kernel_as SR.Vanilla (
let ty = Type.Word16 in
let (set_b, get_b) = new_local env "b"
in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^
compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^
G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And)))
| "btst" -> compile_kernel_as SR.UnboxedWord32 (
let (set_b, get_b) = new_local env "b"
in set_b ^^ compile_unboxed_one ^^ get_b ^^ G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^
G.i (Binary (Wasm.Values.I32 I32Op.And)))
| "btst8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word8)
| "btst16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word16)
| "btst" -> compile_kernel_as SR.UnboxedWord32 (UnboxedSmallWord.btst_kernel env Type.Word32)
| "btst64" -> compile_kernel_as SR.UnboxedInt64 (
let (set_b, get_b) = new_local64 env "b"
in set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^
Expand Down