Commit c4eb4c3f authored by Katharina Brandl's avatar Katharina Brandl
Browse files

new transformer stack - type inference does not work

parent 9f4b0e2b
......@@ -4,7 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Concrete.Except (ExceptT,runExceptT) where
module Control.Arrow.Transformer.Concrete.Except (ExceptT(..),runExceptT) where
import Prelude hiding (id,(.))
......
......@@ -275,7 +275,7 @@ evalParametricInst inst stack =
(->)) (Instruction Natural) ()) (stack,inst)
eval :: [Instruction Natural] -> [Value] -> Generic.Read -> Vector Value -> FrameData ->
eval :: [Instruction Natural] -> [Value] -> Generic.LabelArities -> Vector Value -> FrameData ->
WasmStore Value -> Int ->
([Value], -- stack
Error (Generic.Exc Value)
......@@ -289,7 +289,7 @@ eval inst stack r locals fd wasmStore currentMem =
ValueT Value
(WasmStoreT Value
(FrameT FrameData Value
(ReaderT Generic.Read
(ReaderT Generic.LabelArities
(ExceptT (Generic.Exc Value)
(StackT Value
(->)))))) [Instruction Natural] ()) (stack,(r,(locals,(fd,(wasmStore,(currentMem,inst))))))
......@@ -302,19 +302,19 @@ invokeExported :: WasmStore Value
-> [Value]
-> Error
[Char]
(Error (Exc Value) ([Value],(Vector Value, (WasmStore Value, [Value]))))
(_)
invokeExported store modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
(Generic.invokeExported ::
ValueT Value
(WasmStoreT Value
(FrameT FrameData Value
(ReaderT Generic.Read
(StackT Value
(ExceptT (Generic.Exc Value)
(ReaderT Generic.LabelArities
(StackT Value
(ExceptT (Generic.Exc Value)
(WasmStoreT Value
(FrameT FrameData Value
(FailureT String
(->))))))) (Text, [Value]) [Value]) ([],(Generic.Read [],(Vec.empty,((0,modInst),(store,(0,(funcName,args)))))))
(->))))))) (Text, [Value]) [Value]) (Vec.empty,((0,modInst),(store,(0,([],(Generic.LabelArities [],(funcName,args)))))))
instantiate :: ValidModule -> IO (Either String (ModuleInstance, WasmStore Value))
......
......@@ -28,6 +28,10 @@ import Control.Arrow.Store
import Control.Arrow.Trans
import qualified Control.Arrow.Utils as Arr
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Stack
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Value
......@@ -51,19 +55,19 @@ import Frame
data Exc v = Trap String | Jump Natural [v] | CallReturn [v] deriving (Show, Eq)
-- used for storing the return "arity" of nested labels
newtype Read = Read {labels :: [Natural]}
newtype LabelArities = LabelArities {labels :: [Natural]}
-- stores a frame's static data
type FrameData = (Natural, ModuleInstance)
-- constraints to support (and call) host functions
type HostFunctionSupport addr bytes v c = (ArrowApply c, ArrowWasmStore v c, ArrowWasmMemory addr bytes v c)
-- a host function is a function from a list of values (parameters) to a list of values (return values)
newtype HostFunction v c = HostFunction (
forall addr bytes. HostFunctionSupport addr bytes v c => (c [v] [v]) )
instance Show (HostFunction v c) where
show _ = "HostFunction"
---- constraints to support (and call) host functions
--type HostFunctionSupport addr bytes v c = (ArrowApply c, ArrowWasmStore v c, ArrowWasmMemory addr bytes v c)
---- a host function is a function from a list of values (parameters) to a list of values (return values)
--newtype HostFunction v c = HostFunction (
-- forall addr bytes. HostFunctionSupport addr bytes v c => (c [v] [v]) )
--
--instance Show (HostFunction v c) where
-- show _ = "HostFunction"
class ArrowWasmStore v c | c -> v where
-- | Reads a global variable. Cannot fail due to validation.
......@@ -94,13 +98,21 @@ type ArrowWasmMemory addr bytes v c =
ArrowMemAddress v Natural addr c,
ArrowSerialize v bytes ValueType LoadType StoreType c,
ArrowMemSizable v c)
--Show addr)--, Show bytes)
--Show addr, Show bytes)
class ArrowSerialize val dat valTy datDecTy datEncTy c | c -> datDecTy, c -> datEncTy where
decode :: c (val, x) y -> c x y -> c (dat, datdecTy, valTy, x) y
encode :: c (dat, x) y -> c x y -> c (val, valTy, datEncTy, x) y
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ValueT val2 c)
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ExceptT e c)
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (KleisliT f c) where
-- TODO
deriving instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StackT v c)
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (StateT s c) where
-- TODO
instance (ArrowSerialize val dat valTy datDecTy datEncTy c) => ArrowSerialize val dat valTy datDecTy datEncTy (ReaderT r c) where
-- TODO
class ArrowMemory addr bytes c | c -> addr, c -> bytes where
memread :: c (bytes, x) y -> c x y -> c (addr, Int, x) y
......@@ -118,6 +130,15 @@ class ArrowMemSizable sz c where
memgrow :: c (sz,x) y -> c x y -> c (sz,x) y
deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ValueT val2 c)
deriving instance (Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (ExceptT e c)
instance (Monad f, Arrow c, Profunctor c, ArrowMemSizable sz c) => ArrowMemSizable sz (KleisliT f c) where
memsize = lift' memsize
-- TODO
deriving instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StackT v c)
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (StateT s c) where
-- TODO
instance (ArrowMemSizable sz c) => ArrowMemSizable sz (ReaderT r c) where
-- TODO
data LoadType = L_I32 | L_I64 | L_F32 | L_F64 | L_I8S | L_I8U | L_I16S | L_I16U | L_I32S | L_I32U
deriving Show
......@@ -156,9 +177,14 @@ class Show v => IsVal v c | c -> v where
ifHasType :: c x y -> c x y -> c (v, ValueType, x) y
-- entry point to the generic interpreter
-- the module instance comes from ArrowFrame
-- ArrowWasmStore and ArrowWasmMemory are properly initialized
-- argument Text: name of the function to execute
-- argument [v]: arguments going to be passed to the function
invokeExported ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowWasmStore v c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader Read c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v,
Exc.Join () c,
......@@ -170,14 +196,16 @@ invokeExported ::
)
=> c (Text, [v]) [v]
invokeExported = proc (funcName, args) -> do
(_, modInst) <- frameData -< ()
(_, modInst) <- frameData -< () -- get the module instance
-- look for a function with name funcName in the function's exports
case find (\(ExportInstance n _) -> n == funcName) (exports modInst) of
-- if found -> invoke
Just (ExportInstance _ (ExternFunction addr)) -> invokeExternal -< (addr, args)
_ -> fail -< printf "Function with name %s was not found in module's exports" (show funcName)
invokeExternal ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowWasmStore v c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader Read c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v,
Exc.Join () c,
......@@ -189,21 +217,25 @@ invokeExternal ::
=> c (Int, [v]) [v]
invokeExternal = proc (funcAddr, args) ->
readFunction
-- func: function at address funcAddr in the store
-- function type: paramTys -> resultTys
(proc (func@(FuncType paramTys resultTys, _, _), args) ->
withCheckedType (withRootFrame (invoke eval)) -< (paramTys, args, (resultTys, args, func)))
--(proc (func@(FuncType paramTys resultTys, _), args) ->
-- withCheckedType (withRootFrame invokeHost) -< (paramTys, args, (resultTys, args, func)))
-< (funcAddr, args)
where
-- execute f with "dummy" frame
withRootFrame f = proc (resultTys, args, x) -> do
let rtLength = fromIntegral $ length resultTys
inNewFrame
(proc (rtLength, args, x) -> do
pushn -< args
f -< x
popn -< rtLength)
pushn -< args -- push arguments to the stack
f -< x -- execute function
popn -< rtLength) -- pop result from the stack
-< ((rtLength, emptyModInstance), [], (rtLength, args, x))
-- execute f if arguments match paramTys
withCheckedType f = proc (paramTys, args, x) -> do
if length paramTys /= length args
then fail -< printf "Wrong number of arguments in external invocation. Expected %d but got %d" (length paramTys) (length args)
......@@ -220,7 +252,7 @@ invokeExternal = proc (funcAddr, args) ->
eval ::
( ArrowChoice c, ArrowFrame FrameData v c, ArrowWasmStore v c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader Read c,
ArrowStack v c, ArrowExcept (Exc v) c, ArrowReader LabelArities c,
ArrowWasmMemory addr bytes v c, --HostFunctionSupport addr bytes v c,
IsVal v c, Show v,
Exc.Join () c,
......@@ -252,7 +284,7 @@ evalControlInst ::
ArrowStack v c, -- operand stack of computation
IsVal v c, -- needs to support value operations
ArrowExcept (Exc v) c,
ArrowReader Read c, -- return arity of nested labels
ArrowReader LabelArities c, -- return arity of nested labels
ArrowFrame FrameData v c, -- frame data and local variables
ArrowWasmStore v c,
--HostFunctionSupport addr bytes v c,
......@@ -298,7 +330,7 @@ evalControlInst eval' = proc i -> case i of
-< (tableAddr, fromIntegral ix, ftExpect)
invokeChecked ::
( ArrowChoice c, ArrowWasmStore v c, ArrowStack v c, ArrowReader Read c,
( ArrowChoice c, ArrowWasmStore v c, ArrowStack v c, ArrowReader LabelArities c,
IsVal v c, ArrowFrame FrameData v c, ArrowExcept (Exc v) c, Exc.Join () c)
--HostFunctionSupport addr bytes v c)
=> c [Instruction Natural] () -> c (Int, FuncType) ()
......@@ -315,17 +347,30 @@ invokeChecked eval' = proc (addr, ftExpect) ->
then f -< x
else throw -< Trap $ printf "Mismatched function type in indirect call. Expected %s, actual %s." (show ftExpect) (show ftActual)
-- TODO: we need to catch CallReturn
-- invoke function with code code within module instance funcModInst
-- the function execution can finish by different reasons:
-- - all instructions have been executed -> result are the top |resultTys| values on the stack
-- - the function calls return -> result are the top |resultTys| values on the stack
-- - the function produces a trap -> no result, trap is propagated
-- - TODO: what about break? Can we "break" to a function boundary? -> NO, only to block boundaries
invoke ::
( ArrowChoice c, ArrowStack v c, ArrowReader Read c,
( ArrowChoice c, ArrowStack v c, ArrowReader LabelArities c,
IsVal v c, ArrowFrame FrameData v c, ArrowExcept (Exc v) c, Exc.Join y c)
=> c [Instruction Natural] y -> c (FuncType, ModuleInstance, Function) y
invoke eval' = proc (FuncType paramTys resultTys, funcModInst, Function _ localTys code) -> do
vs <- popn -< fromIntegral $ length paramTys
zeros <- Arr.map initLocal -< localTys
let rtLength = fromIntegral $ length resultTys
-- TODO: removed localFreshStack, not sure if that is what we want
inNewFrame (localNoLabels $ label eval' eval') -< ((rtLength, funcModInst), vs ++ zeros, (resultTys, code, []))
invoke eval' = catch
(proc (FuncType paramTys resultTys, funcModInst, Function _ localTys code) -> do
vs <- popn -< fromIntegral $ length paramTys
zeros <- Arr.map initLocal -< localTys
let rtLength = fromIntegral $ length resultTys
-- TODO: removed localFreshStack, not sure if that is what we want
inNewFrame (localNoLabels $ label eval' eval') -< ((rtLength, funcModInst), vs ++ zeros, (resultTys, code, [])))
(proc (_,e) -> case e of
CallReturn vs -> do
pushn -< vs
eval' -< []
Trap _ -> throw -< e
Jump _ _ -> returnA -< error "invalid module: tried to jump through a function boundary")
where
initLocal :: (ArrowChoice c, IsVal v c) => c ValueType v
initLocal = proc ty -> case ty of
......@@ -334,45 +379,51 @@ invoke eval' = proc (FuncType paramTys resultTys, funcModInst, Function _ localT
F32 -> f32const -< 0
F64 -> f64const -< 0
invokeHost ::
(ArrowChoice c, ArrowStack v c, HostFunctionSupport addr bytes v c)
=> c (FuncType, HostFunction v c) ()
invokeHost = proc (FuncType paramTys _, HostFunction hostFunc) -> do
vs <- popn -< fromIntegral $ length paramTys
pushn <<< app -< (hostFunc, vs)
--invokeHost ::
-- (ArrowChoice c, ArrowStack v c, HostFunctionSupport addr bytes v c)
-- => c (FuncType, HostFunction v c) ()
--invokeHost = proc (FuncType paramTys _, HostFunction hostFunc) -> do
-- vs <- popn -< fromIntegral $ length paramTys
-- pushn <<< app -< (hostFunc, vs)
branch :: (ArrowChoice c, ArrowExcept (Exc v) c, ArrowStack v c, ArrowReader Read c) => c Natural ()
branch :: (ArrowChoice c, ArrowExcept (Exc v) c, ArrowStack v c, ArrowReader LabelArities c) => c Natural ()
branch = proc ix -> do
Read{labels=ls} <- ask -< ()
LabelArities{labels=ls} <- ask -< ()
vs <- popn -< ls !! fromIntegral ix
throw -< Jump ix vs
-- | Introduces a branching point `g` that can be jumped to from within `f`.
-- | When escalating jumps, all label-local operands must be popped from the stack.
-- | This implementation assumes that ArrowExcept discards label-local operands in ArrowStack upon throw.
label :: (ArrowChoice c, ArrowExcept (Exc v) c, ArrowStack v c, ArrowReader Read c, Exc.Join z c)
label :: (ArrowChoice c, ArrowExcept (Exc v) c, ArrowStack v c, ArrowReader LabelArities c, Exc.Join z c)
=> c x z -> c y z -> c (ResultType, x, y) z
-- x: code to execute
-- y: continuation to execute after a break to the current label
label f g = catch
-- after executing f without a break we expect |rt| results on top of the stack
(proc (rt,x,_) -> localLabel f -< (rt, x))
-- after a break the results are popped from the stack and passed back via exception e
(proc ((_,_,y),e) -> case e of
Jump 0 vs -> do
pushn -< vs
g -< y
-- we expect all label-local operands are popped from the stack
Jump n vs -> throw -< Jump (n-1) vs
_ -> throw -< e
)
localLabel :: (ArrowReader Read c) => c x y -> c (ResultType, x) y
localLabel :: (ArrowReader LabelArities c) => c x y -> c (ResultType, x) y
localLabel f = proc (rt, x) -> do
r@Read{labels=ls} <- ask -< ()
r@LabelArities{labels=ls} <- ask -< ()
let l = fromIntegral $ length rt
local f -< (r{labels=l:ls}, x)
localNoLabels :: (ArrowReader Read c) => c x y -> c x y
-- reset all label arities locally and execute f
localNoLabels :: (ArrowReader LabelArities c) => c x y -> c x y
localNoLabels f = proc x -> do
r <- ask -< ()
local f -< (r{labels=[]}, x)
--r <- ask -< ()
local f -< (LabelArities{labels=[]}, x)
evalParametricInst :: (ArrowChoice c, Profunctor c, ArrowStack v c, IsVal v c)
=> c (Instruction Natural) ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment