Skip to content
New issue

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

#

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

Already on GitHub? # to your account

Simplify memops #39

Closed
wants to merge 1 commit into from
Closed

Simplify memops #39

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
13 changes: 5 additions & 8 deletions ml-proto/README.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -152,18 +152,15 @@ The S-expression syntax is defined in `parser.mly`, the opcodes in `lexer.mll`.

```
type: i32 | i64 | f32 | f64
memtype: <type> | i8 | i16

size: 8 | 16 | 32 | 64
value: <int> | <float>
var: <int> | $<name>

unop: neg | abs | not | ...
binop: add | sub | mul | ...
relop: eq | neq | lt | ...
sign: s|u
align: 1|2|4|8|...
memop: (<sign>.)?(<align>.)?
cvtop: trunc_s | trunc_u | extend_s | extend_u | ...
cvtop: wrap | trunc_<sign> | extend_<sign> | ...
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess this was already present, but is there a reason why there are signed and unsigned forms of trunc here?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Well, they exist in AstSemantics.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oh, right. This is as it should be.

sign: s | u

expr:
( nop )
Expand All @@ -183,8 +180,8 @@ expr:
( set_local <var> <expr> )
( load_global <var> )
( store_global <var> <expr> )
( <type>.load<memop><memtype> <expr> )
( <type>.store<memop><memtype> <expr> <expr> )
( <type>.load<size>(_<sign>)?(/<nat>)? <expr> )
( <type>.store<size>(/<nat>)? <expr> <expr> )
( <type>.const <value> )
( <type>.<unop> <expr> )
( <type>.<binop> <expr> <expr> )
Expand Down
3 changes: 2 additions & 1 deletion ml-proto/src/ast.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -62,7 +62,8 @@ type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op
type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op
type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op

type memop = {ty : Types.value_type; mem : Memory.mem_type; align : int}
type memop =
{ty : Types.value_type; size : int; align : int; signed : bool option}
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Perhaps size : int could be replaced by mty : memory_type? That type seems a bit "tighter" (without ruling out interesting cases). In theory, having size be a simple integer lets you deal with size independently of float vs. integer, but I didn't see that helping in practice here, although I could've missed it.



(* Expressions *)
Expand Down
37 changes: 12 additions & 25 deletions ml-proto/src/check.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -55,18 +55,6 @@ let nary = List.map (fun ty -> [ty])

(* Type Synthesis *)

let type_mem = function
| Memory.SInt8Mem -> Int32Type
| Memory.SInt16Mem -> Int32Type
| Memory.SInt32Mem -> Int32Type
| Memory.SInt64Mem -> Int64Type
| Memory.UInt8Mem -> Int32Type
| Memory.UInt16Mem -> Int32Type
| Memory.UInt32Mem -> Int32Type
| Memory.UInt64Mem -> Int64Type
| Memory.Float32Mem -> Float32Type
| Memory.Float64Mem -> Float64Type

let type_value = Values.type_of
let type_unop = Values.type_of
let type_binop = Values.type_of
Expand Down Expand Up @@ -189,12 +177,12 @@ let rec check_expr c ts e =
check_type [] ts e.at

| Load (memop, e1) ->
check_memop memop e.at;
check_memop memop false e.at;
check_expr c [Int32Type] e1;
check_type [type_mem memop.mem] ts e.at
check_type [memop.ty] ts e.at

| Store (memop, e1, e2) ->
check_memop memop e.at;
check_memop memop true e.at;
check_expr c [Int32Type] e1;
check_expr c [memop.ty] e2;
check_type [] ts e.at
Expand Down Expand Up @@ -239,17 +227,16 @@ and check_arm c t ts arm =
check_literal c [t] l;
check_expr c (if fallthru then [] else ts) e

and check_memop {ty; mem; align} at =
and check_memop {ty; size; align; signed} is_store at =
require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment";
let open Memory in
match mem, ty with
| (SInt8Mem | SInt16Mem | SInt32Mem), Int32Type
| (UInt8Mem | UInt16Mem | UInt32Mem), Int32Type
| (SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem), Int64Type
| (UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem), Int64Type
| Float32Mem, Float32Type
| Float64Mem, Float64Type -> ()
| _ -> error at "type-inconsistent memory operator"
match ty, size, (signed, is_store) with
| Int32Type, (8 | 16), ((Some _, false) | (None, true))
| Int32Type, 32, (None, _)
| Int64Type, (8 | 16 | 32), ((Some _, false) | (None, true))
| Int64Type, 64, (None, _)
| Float32Type, 32, (None, _)
| Float64Type, 64, (None, _) -> ()
| _ -> error at "invalid memory operator"


(*
Expand Down
8 changes: 4 additions & 4 deletions ml-proto/src/eval.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -162,15 +162,15 @@ let rec eval_expr c e =
global c x := v1;
[]

| Load ({mem; ty; _}, e1) ->
| Load ({ty; size; signed; _}, e1) ->
let v1 = unary (eval_expr c e1) e1.at in
(try [Memory.load c.modul.memory (Memory.address_of_value v1) mem ty]
(try [Memory.load c.modul.memory (Memory.address_of_value v1) size ty signed]
with exn -> memory_error e.at exn)

| Store ({mem; _}, e1, e2) ->
| Store ({size; _}, e1, e2) ->
let v1 = unary (eval_expr c e1) e1.at in
let v2 = unary (eval_expr c e2) e2.at in
(try Memory.store c.modul.memory (Memory.address_of_value v1) mem v2
(try Memory.store c.modul.memory (Memory.address_of_value v1) size v2
with exn -> memory_error e.at exn);
[]

Expand Down
43 changes: 12 additions & 31 deletions ml-proto/src/lexer.mll
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -60,25 +60,11 @@ let floatop t f32 f64 =
| "f64" -> Values.Float64 f64
| _ -> assert false

let mem_type t sign memty =
let open Memory in
match t, sign, memty with
| ("i32" | "i64"), 's', "i8" -> SInt8Mem
| ("i32" | "i64"), 's', "i16" -> SInt16Mem
| ("i32" | "i64"), 's', "i32" -> SInt32Mem
| "i64", 's', "i64" -> SInt64Mem
| ("i32" | "i64"), 'u', "i8" -> UInt8Mem
| ("i32" | "i64"), 'u', "i16" -> UInt16Mem
| ("i32" | "i64"), 'u', "i32" -> UInt32Mem
| "i64", 'u', "i64" -> UInt64Mem
| "f32", ' ', "f32" -> Float32Mem
| "f64", ' ', "f64" -> Float64Mem
| _ -> assert false

let memop ty sign memsize a =
let memty = mem_type ty sign memsize in
let align = if a = "" then Memory.mem_size memty else int_of_string a in
{ty = value_type ty; mem = memty; align}
let size = int_of_string memsize in
let align = if a = "" then size else int_of_string a in
let signed = if sign = ' ' then None else Some (sign = 's') in
{ty = value_type ty; size; align; signed}
}


Expand All @@ -91,6 +77,7 @@ let tick = '\''
let escape = ['n''t''\\''\'''\"']
let character = [^'"''\\''\n'] | '\\'escape | '\\'hexdigit hexdigit

let nat = digit+
let num = ('+' | '-')? digit+
let int = num
let float = (num '.' digit+) | num ('.' digit+)? ('e' | 'E') num
Expand All @@ -100,10 +87,8 @@ let name = '$' (letter | digit | '_' | tick | symbol)+
let ixx = "i" ("32" | "64")
let fxx = "f" ("32" | "64")
let nxx = ixx | fxx
let mixx = "i" ("8" | "16" | "32" | "64")
let mfxx = "f" ("32" | "64")
let size = "8" | "16" | "32" | "64"
let sign = "s" | "u"
let align = digit+

rule token = parse
| "(" { LPAR }
Expand Down Expand Up @@ -139,17 +124,13 @@ rule token = parse
| "load_global" { LOADGLOBAL }
| "store_global" { STOREGLOBAL }

| (ixx as t)".load_"(sign as s)"/"(mixx as m)"/"(align as a)
| (ixx as t)".load"(size as m)"_"(sign as s)"/"(nat as a)
{ LOAD (memop t s m a) }
| (ixx as t)".load_"(sign as s)"/"(mixx as m) { LOAD (memop t s m "") }
| (ixx as t)".load/"(mixx as m)"/"(align as a) { LOAD (memop t 's' m a) }
| (ixx as t)".load/"(mixx as m) { LOAD (memop t 's' m "") }
| (ixx as t)".store/"(mixx as m)"/"(align as a) { STORE (memop t 's' m a) }
| (ixx as t)".store/"(mixx as m) { STORE (memop t 's' m "") }
| (fxx as t)".load/"(mfxx as m)"/"(align as a) { LOAD (memop t ' ' m a) }
| (fxx as t)".store/"(mfxx as m)"/"(align as a) { STORE (memop t ' ' m a) }
| (fxx as t)".load/"(mfxx as m) { LOAD (memop t ' ' m "") }
| (fxx as t)".store/"(mfxx as m) { STORE (memop t ' ' m "") }
| (ixx as t)".load"(size as m)"_"(sign as s) { LOAD (memop t s m "") }
| (nxx as t)".load"(size as m)"/"(nat as a) { LOAD (memop t ' ' m a) }
| (nxx as t)".load"(size as m) { LOAD (memop t ' ' m "") }
| (nxx as t)".store"(size as m)"/"(nat as a) { STORE (memop t ' ' m a) }
| (nxx as t)".store"(size as m) { STORE (memop t ' ' m "") }

| (nxx as t)".switch" { SWITCH (value_type t) }
| (nxx as t)".const" { CONST (value_type t) }
Expand Down
108 changes: 46 additions & 62 deletions ml-proto/src/memory.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,11 +9,7 @@ open Bigarray

type address = int
type size = address
type mem_size = int
type mem_type =
| SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
| UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
| Float32Mem | Float64Mem
type signed = bool option

type segment =
{
Expand All @@ -26,28 +22,17 @@ type t = memory

type char_view = (char, int8_unsigned_elt, c_layout) Array1.t
type sint8_view = (int, int8_signed_elt, c_layout) Array1.t
type sint16_view = (int, int16_signed_elt, c_layout) Array1.t
type sint32_view = (int32, int32_elt, c_layout) Array1.t
type sint64_view = (int64, int64_elt, c_layout) Array1.t
type uint8_view = (int, int8_unsigned_elt, c_layout) Array1.t
type sint16_view = (int, int16_signed_elt, c_layout) Array1.t
type uint16_view = (int, int16_unsigned_elt, c_layout) Array1.t
type uint32_view = (int32, int32_elt, c_layout) Array1.t
type uint64_view = (int64, int64_elt, c_layout) Array1.t
type int32_view = (int32, int32_elt, c_layout) Array1.t
type int64_view = (int64, int64_elt, c_layout) Array1.t
type float32_view = (float, float32_elt, c_layout) Array1.t
type float64_view = (float, float64_elt, c_layout) Array1.t

let view : memory -> ('c, 'd, c_layout) Array1.t = Obj.magic


(* Queries *)

let mem_size = function
| SInt8Mem | UInt8Mem -> 1
| SInt16Mem | UInt16Mem -> 2
| SInt32Mem | UInt32Mem | Float32Mem -> 4
| SInt64Mem | UInt64Mem | Float64Mem -> 8


(* Creation and initialization *)

exception Type
Expand Down Expand Up @@ -83,53 +68,52 @@ let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask

let buf = create 8

let load mem a memty valty =
let sz = mem_size memty in
let open Types in
let load mem a sz t signed =
try
Array1.blit (Array1.sub mem a sz) (Array1.sub buf 0 sz);
match memty, valty with
| SInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint8_view).{0})
| SInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint8_view).{0})
| SInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint16_view).{0})
| SInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint16_view).{0})
| SInt32Mem, Int32Type -> Int32 (view buf : sint32_view).{0}
| SInt32Mem, Int64Type ->
Int64 (Int64.of_int32 (view buf : sint32_view).{0})
| SInt64Mem, Int64Type -> Int64 (view buf : sint64_view).{0}
| UInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint8_view).{0})
| UInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint8_view).{0})
| UInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint16_view).{0})
| UInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint16_view).{0})
| UInt32Mem, Int32Type -> Int32 (view buf : uint32_view).{0}
| UInt32Mem, Int64Type ->
Int64 (int64_of_int32_u (view buf : uint32_view).{0})
| UInt64Mem, Int64Type -> Int64 (view buf : uint64_view).{0}
| Float32Mem, Float32Type -> Float32 (view buf : float32_view).{0}
| Float64Mem, Float64Type -> Float64 (view buf : float64_view).{0}
Array1.blit (Array1.sub mem a (sz/8)) (Array1.sub buf 0 (sz/8));
let open Types in
match t, sz, signed with
| Int32Type, 8, Some true ->
Int32 (Int32.of_int (view buf : sint8_view).{0})
| Int32Type, 8, Some false ->
Int32 (Int32.of_int (view buf : uint8_view).{0})
| Int32Type, 16, Some true ->
Int32 (Int32.of_int (view buf : sint16_view).{0})
| Int32Type, 16, Some false ->
Int32 (Int32.of_int (view buf : uint16_view).{0})
| Int32Type, 32, None ->
Int32 (view buf : int32_view).{0}
| Int64Type, 8, Some true ->
Int64 (Int64.of_int (view buf : sint8_view).{0})
| Int64Type, 8, Some false ->
Int64 (Int64.of_int (view buf : uint8_view).{0})
| Int64Type, 16, Some true ->
Int64 (Int64.of_int (view buf : sint16_view).{0})
| Int64Type, 16, Some false ->
Int64 (Int64.of_int (view buf : uint16_view).{0})
| Int64Type, 32, Some true ->
Int64 (Int64.of_int32 (view buf : int32_view).{0})
| Int64Type, 32, Some false ->
Int64 (int64_of_int32_u (view buf : int32_view).{0})
| Int64Type, 64, None ->
Int64 (view buf : int64_view).{0}
| Float32Type, 32, None -> Float32 (view buf : float32_view).{0}
| Float64Type, 64, None -> Float64 (view buf : float64_view).{0}
| _ -> raise Type
with Invalid_argument _ -> raise Bounds

let store mem a memty v =
let sz = mem_size memty in
let store mem a sz v =
try
(match memty, v with
| SInt8Mem, Int32 x -> (view buf : sint8_view).{0} <- Int32.to_int x
| SInt8Mem, Int64 x -> (view buf : sint8_view).{0} <- Int64.to_int x
| SInt16Mem, Int32 x -> (view buf : sint16_view).{0} <- Int32.to_int x
| SInt16Mem, Int64 x -> (view buf : sint16_view).{0} <- Int64.to_int x
| SInt32Mem, Int32 x -> (view buf : sint32_view).{0} <- x
| SInt32Mem, Int64 x -> (view buf : sint32_view).{0} <- Int64.to_int32 x
| SInt64Mem, Int64 x -> (view buf : sint64_view).{0} <- x
| UInt8Mem, Int32 x -> (view buf : uint8_view).{0} <- Int32.to_int x
| UInt8Mem, Int64 x -> (view buf : uint8_view).{0} <- Int64.to_int x
| UInt16Mem, Int32 x -> (view buf : uint16_view).{0} <- Int32.to_int x
| UInt16Mem, Int64 x -> (view buf : uint16_view).{0} <- Int64.to_int x
| UInt32Mem, Int32 x -> (view buf : uint32_view).{0} <- x
| UInt32Mem, Int64 x -> (view buf : uint32_view).{0} <- Int64.to_int32 x
| UInt64Mem, Int64 x -> (view buf : uint64_view).{0} <- x
| Float32Mem, Float32 x -> (view buf : float32_view).{0} <- x
| Float64Mem, Float64 x -> (view buf : float64_view).{0} <- x
(match v, sz with
| Int32 x, 8 -> (view buf : sint8_view).{0} <- Int32.to_int x
| Int64 x, 8 -> (view buf : sint8_view).{0} <- Int64.to_int x
| Int32 x, 16 -> (view buf : sint16_view).{0} <- Int32.to_int x
| Int64 x, 16 -> (view buf : sint16_view).{0} <- Int64.to_int x
| Int32 x, 32 -> (view buf : int32_view).{0} <- x
| Int64 x, 32 -> (view buf : int32_view).{0} <- Int64.to_int32 x
| Int64 x, 64 -> (view buf : int64_view).{0} <- x
| Float32 x, 32 -> (view buf : float32_view).{0} <- x
| Float64 x, 64 -> (view buf : float64_view).{0} <- x
| _ -> raise Type);
Array1.blit (Array1.sub buf 0 sz) (Array1.sub mem a sz)
Array1.blit (Array1.sub buf 0 (sz/8)) (Array1.sub mem a (sz/8))
with Invalid_argument _ -> raise Bounds
11 changes: 3 additions & 8 deletions ml-proto/src/memory.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,11 +6,7 @@ type memory
type t = memory
type address = int
type size = address
type mem_size = int
type mem_type =
| SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
| UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
| Float32Mem | Float64Mem
type signed = bool option

type segment = {addr : address; data : string}

Expand All @@ -20,8 +16,7 @@ exception Address

val create : size -> memory
val init : memory -> segment list -> unit
val load : memory -> address -> mem_type -> Types.value_type -> Values.value
val store : memory -> address -> mem_type -> Values.value -> unit
val load : memory -> address -> size -> Types.value_type -> signed -> Values.value
val store : memory -> address -> size -> Values.value -> unit

val mem_size : mem_type -> mem_size
val address_of_value : Values.value -> address
Loading