Skip to content

Commit

Permalink
Adapt memory operations
Browse files Browse the repository at this point in the history
  • Loading branch information
@rossberg
rossberg committed Aug 28, 2015
1 parent 453f64d commit 6f5b968
Show file tree
Hide file tree
Showing 12 changed files with 153 additions and 120 deletions.
2 changes: 1 addition & 1 deletion ml-proto/src/ast.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -62,7 +62,7 @@ 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 = {align : int; mem : Memory.mem_type}
type memop = {ty : Types.value_type; mem : Memory.mem_type; align : int}

This comment has been minimized.

Sign in to view

Copy link
@lukewagner

lukewagner Sep 2, 2015

Member

This could be a followup patch, but I still think it would be nice if there was a Types.memory_type which exactly matched AstSemantics.md (no Int8 instead of SInt8Mem vs UInt8Mem). This would imply giving Load an extra SX|ZX|NX immediate.


(* Expressions *)
Expand Down
15 changes: 12 additions & 3 deletions ml-proto/src/check.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -196,7 +196,7 @@ let rec check_expr c ts e =
| Store (memop, e1, e2) ->
check_memop memop e.at;
check_expr c [Int32Type] e1;
check_expr c [type_mem memop.mem] e2;
check_expr c [memop.ty] e2;
check_type [] ts e.at

| Const v ->
Expand Down Expand Up @@ -239,8 +239,17 @@ and check_arm c t ts arm =
check_literal c [t] l;
check_expr c (if fallthru then [] else ts) e

and check_memop memop at =
require (Lib.is_power_of_two memop.align) at "non-power-of-two alignment"
and check_memop {ty; mem; align} 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"


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

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

| Store ({mem; _}, e1, e2) ->
Expand Down
95 changes: 46 additions & 49 deletions ml-proto/src/lexer.mll
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,21 +48,6 @@ let value_type = function
| "f64" -> Types.Float64Type
| _ -> assert false

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

let intop t i32 i64 =
match t with
| "i32" -> Values.Int32 i32
Expand All @@ -75,16 +60,25 @@ let floatop t f32 f64 =
| "f64" -> Values.Float64 f64
| _ -> assert false

let default_alignment = function
| "i8" -> 1
| "i16" -> 2
| "i32" | "f32" -> 4
| "i64" | "f64" -> 8
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 a s t =
let align = if a = "" then default_alignment t else int_of_string a in
{align; mem = mem_type s t}
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}
}


Expand Down Expand Up @@ -145,16 +139,19 @@ rule token = parse
| "load_global" { LOADGLOBAL }
| "store_global" { STOREGLOBAL }

| "load_"(sign as s)"."(align as a)"."(mixx as t) { LOAD (memop a s t) }
| "store_"(sign as s)"."(align as a)"."(mixx as t) { STORE (memop a s t) }
| "load_"(sign as s)"."(mixx as t) { LOAD (memop "" s t) }
| "store_"(sign as s)"."(mixx as t) { STORE (memop "" s t) }
| "load."(align as a)"."(mfxx as t) { LOAD (memop a ' ' t) }
| "store."(align as a)"."(mfxx as t) { STORE (memop a ' ' t) }
| "load."(mfxx as t) { LOAD (memop "" ' ' t) }
| "store."(mfxx as t) { STORE (memop "" ' ' t) }
| (ixx as t)".load_"(sign as s)"/"(mixx as m)"/"(align 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 "") }

| "switch."(nxx as t) { SWITCH (value_type t) }
| "switch/"(nxx as t) { SWITCH (value_type t) }
| (nxx as t)".const" { CONST (value_type t) }

| (ixx as t)".neg" { UNARY (intop t Int32Op.Neg Int64Op.Neg) }
Expand Down Expand Up @@ -206,31 +203,31 @@ rule token = parse
| (fxx as t)".gt" { COMPARE (floatop t Float32Op.Gt Float64Op.Gt) }
| (fxx as t)".ge" { COMPARE (floatop t Float32Op.Ge Float64Op.Ge) }

| "i64.extend_s.i32" { CONVERT (Values.Int64 Int64Op.ExtendSInt32) }
| "i64.extend_u.i32" { CONVERT (Values.Int64 Int64Op.ExtendUInt32) }
| "i64.wrap.i64" { CONVERT (Values.Int32 Int32Op.WrapInt64) }
| (ixx as t)".trunc_s.f32"
| "i64.extend_s/i32" { CONVERT (Values.Int64 Int64Op.ExtendSInt32) }
| "i64.extend_u/i32" { CONVERT (Values.Int64 Int64Op.ExtendUInt32) }
| "i64.wrap/i64" { CONVERT (Values.Int32 Int32Op.WrapInt64) }
| (ixx as t)".trunc_s/f32"
{ CONVERT (intop t Int32Op.TruncSFloat32 Int64Op.TruncSFloat32) }
| (ixx as t)".trunc_u.f32"
| (ixx as t)".trunc_u/f32"
{ CONVERT (intop t Int32Op.TruncUFloat32 Int64Op.TruncUFloat32) }
| (ixx as t)".trunc_s.f64"
| (ixx as t)".trunc_s/f64"
{ CONVERT (intop t Int32Op.TruncSFloat64 Int64Op.TruncSFloat64) }
| (ixx as t)".trunc_u.f64"
| (ixx as t)".trunc_u/f64"
{ CONVERT (intop t Int32Op.TruncUFloat64 Int64Op.TruncUFloat64) }
| (fxx as t)".convert_s.i32"
| (fxx as t)".convert_s/i32"
{ CONVERT (floatop t Float32Op.ConvertSInt32 Float64Op.ConvertSInt32) }
| (fxx as t)".convert_u.i32"
| (fxx as t)".convert_u/i32"
{ CONVERT (floatop t Float32Op.ConvertUInt32 Float64Op.ConvertUInt32) }
| (fxx as t)".convert_s.i64"
| (fxx as t)".convert_s/i64"
{ CONVERT (floatop t Float32Op.ConvertSInt64 Float64Op.ConvertSInt64) }
| (fxx as t)".convert_u.i64"
| (fxx as t)".convert_u/i64"
{ CONVERT (floatop t Float32Op.ConvertUInt64 Float64Op.ConvertUInt64) }
| "f64.promote.f32" { CONVERT (Values.Float64 Float64Op.PromoteFloat32) }
| "f32.demote.f64" { CONVERT (Values.Float32 Float32Op.DemoteFloat64) }
| "f32.reinterpret.i32" { CONVERT (Values.Float32 Float32Op.ReinterpretInt) }
| "f64.reinterpret.i64" { CONVERT (Values.Float64 Float64Op.ReinterpretInt) }
| "i32.reinterpret.f32" { CONVERT (Values.Int32 Int32Op.ReinterpretFloat) }
| "i64.reinterpret.f64" { CONVERT (Values.Int64 Int64Op.ReinterpretFloat) }
| "f64.promote/f32" { CONVERT (Values.Float64 Float64Op.PromoteFloat32) }
| "f32.demote/f64" { CONVERT (Values.Float32 Float32Op.DemoteFloat64) }
| "f32.reinterpret/i32" { CONVERT (Values.Float32 Float32Op.ReinterpretInt) }
| "f64.reinterpret/i64" { CONVERT (Values.Float64 Float64Op.ReinterpretInt) }
| "i32.reinterpret/f32" { CONVERT (Values.Int32 Int32Op.ReinterpretFloat) }
| "i64.reinterpret/f64" { CONVERT (Values.Int64 Int64Op.ReinterpretFloat) }

| "func" { FUNC }
| "param" { PARAM }
Expand Down
9 changes: 6 additions & 3 deletions ml-proto/src/lib.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,6 +38,9 @@ struct
| None -> ()
end

let is_power_of_two x =
assert (x >= 0);
x <> 0 && (x land (x - 1)) == 0
module Int =
struct
let is_power_of_two x =
if x < 0 then failwith "is_power_of_two";
x <> 0 && (x land (x - 1)) = 0
end
5 changes: 4 additions & 1 deletion ml-proto/src/lib.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,4 +19,7 @@ sig
val app : ('a -> unit) -> 'a option -> unit
end

val is_power_of_two : int -> bool
module Int :
sig
val is_power_of_two : int -> bool
end
71 changes: 47 additions & 24 deletions ml-proto/src/memory.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,18 +9,12 @@ open Bigarray

type address = int
type size = address
type alignment = Aligned | Unaligned
type mem_size = int
type mem_type =
| SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
| UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
| Float32Mem | Float64Mem

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

type segment =
{
addr : address;
Expand All @@ -45,8 +39,18 @@ 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
exception Bounds
exception Address

Expand Down Expand Up @@ -74,39 +78,58 @@ let address_of_value = function

(* Load and store *)

let int32_mask = Int64.shift_right_logical (Int64.of_int (-1)) 32
let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask

let buf = create 8

let load mem a ty =
let sz = mem_size ty in
let load mem a memty valty =
let sz = mem_size memty in
let open Types in
try
Array1.blit (Array1.sub mem a sz) (Array1.sub buf 0 sz);
match ty with
| SInt8Mem -> Int32 (Int32.of_int (view buf : sint8_view).{0})
| SInt16Mem -> Int32 (Int32.of_int (view buf : sint16_view).{0})
| SInt32Mem -> Int32 (view buf : sint32_view).{0}
| SInt64Mem -> Int64 (view buf : sint64_view).{0}
| UInt8Mem -> Int32 (Int32.of_int (view buf : uint8_view).{0})
| UInt16Mem -> Int32 (Int32.of_int (view buf : uint16_view).{0})
| UInt32Mem -> Int32 (view buf : uint32_view).{0}
| UInt64Mem -> Int64 (view buf : uint64_view).{0}
| Float32Mem -> Float32 (view buf : float32_view).{0}
| Float64Mem -> Float64 (view buf : float64_view).{0}
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}
| _ -> raise Type
with Invalid_argument _ -> raise Bounds

let store mem a ty v =
let sz = mem_size ty in
let store mem a memty v =
let sz = mem_size memty in
try
(match ty, v with
(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
| _ -> assert false);
| _ -> raise Type);
Array1.blit (Array1.sub buf 0 sz) (Array1.sub mem a sz)
with Invalid_argument _ -> raise Bounds
12 changes: 5 additions & 7 deletions ml-proto/src/memory.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,24 +6,22 @@ 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
val mem_size : mem_type -> int

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

exception Type
exception Bounds
exception Address

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

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

0 comments on commit 6f5b968

Please sign in to comment.