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

Merge branch 'wasm' into upstream/wasm

parents 899d77b3 9148384c
Pipeline #98735 passed with stages
in 74 minutes and 31 seconds
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Stack where
import Control.Arrow
import Control.Arrow.Trans
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Data.Profunctor.Unsafe
import Numeric.Natural (Natural)
class ArrowStack v c | c -> v where
push :: c v ()
pop :: c () v
peek :: c () v
ifEmpty :: c x y -> c x y -> c x y
localFreshStack :: c x y -> c x y
pop2 :: (ArrowStack v c, ArrowChoice c) => c () (v, v)
pop2 = proc _ -> do
v2 <- pop -< ()
v1 <- pop -< ()
returnA -< (v1, v2)
popn :: (ArrowStack v c, ArrowChoice c) => c Natural [v]
popn = proc n -> case n of
0 -> returnA -< []
_ -> do
v <- pop -< ()
vs <- popn -< n-1
returnA -< v:vs
pushn :: (ArrowStack v c, ArrowChoice c) => c [v] ()
pushn = proc vs -> case vs of
[] -> returnA -< ()
v:vs' -> do
pushn -< vs'
push -< v
---------------- instances -------------------------
instance (Profunctor c, Arrow c, Monad f, ArrowStack v c) => ArrowStack v (KleisliT f c) where
push = lift' push
pop = lift' pop
peek = lift' peek
ifEmpty a1 a2 = lift (ifEmpty (unlift a1) (unlift a2))
localFreshStack a = lift (localFreshStack (unlift a))
instance (Profunctor c, Arrow c, ArrowStack v c) => ArrowStack v (ReaderT r c) where
push = lift' push
pop = lift' pop
peek = lift' peek
ifEmpty a1 a2 = lift (ifEmpty (unlift a1) (unlift a2))
localFreshStack a = lift (localFreshStack (unlift a))
instance (Profunctor c, Arrow c, ArrowStack v c) => ArrowStack v (StateT st c) where
push = lift' push
pop = lift' pop
peek = lift' peek
ifEmpty a1 a2 = lift (ifEmpty (unlift a1) (unlift a2))
localFreshStack a = lift (localFreshStack (unlift a))
......@@ -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,(.))
......@@ -17,6 +17,7 @@ import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
......@@ -32,7 +33,7 @@ import Data.Coerce
newtype ExceptT e c x y = ExceptT (KleisliT (Error e) c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLift,ArrowTrans,ArrowRun,
ArrowConst r,ArrowState s,ArrowReader r,ArrowFail err,
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val)
ArrowEnv var val, ArrowClosure expr cls,ArrowStore var val, ArrowStack st)
runExceptT :: ExceptT e c x y -> c x (Error e y)
runExceptT = coerce
......
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.Stack where
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Trans
import Control.Arrow.Transformer.State
import Control.Arrow.Utils
import Data.Profunctor
import Data.Coerce
-- | Arrow transformer that adds a stack to a computation.
newtype StackT v c x y = StackT (StateT [v] c x y)
deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowTrans,ArrowLift,ArrowRun,
ArrowConst r, ArrowReader r, ArrowFail e, ArrowExcept e, ArrowState [v])
-- | Execute a computation and only return the result value and store.
runStackT :: StackT v c x y -> c ([v], x) ([v], y)
runStackT = coerce
{-# INLINE runStackT #-}
-- | Execute a computation and only return the result value.
evalStackT :: (Profunctor c) => StackT v c x y -> c ([v], x) y
evalStackT f = rmap pi2 (runStackT f)
-- | Execute a computation and only return the result store.
execStackT :: (Profunctor c) => StackT v c x y -> c ([v], x) [v]
execStackT f = rmap pi1 (runStackT f)
instance (ArrowChoice c, Profunctor c) => ArrowStack v (StackT v c) where
push = StackT $ modify $ arr $ \(v,st) -> ((), v:st)
pop = StackT $ modify $ arr $ \((),v:st) -> (v, st)
peek = StackT $ get >>^ head
ifEmpty (StackT f) (StackT g) = StackT $ proc x -> do
st <- get -< ()
case st of
[] -> g -< x
_ -> f -< x
localFreshStack (StackT f) = StackT $ proc x -> do
st <- get -< ()
put -< []
y <- f -< x
put -< st
returnA -< y
--pop2 = StackT $ modify $ arr $ \((),v2:v1:st) -> ((v1,v2), st)
--popn = StackT $ modify $ arr $ \(n,st) -> splitAt (fromIntegral n) st
--pushn = StackT $ modify $ arr $ \(st',st) -> ((),st'++st)
instance ArrowFix (Underlying (StackT v c) x y) => ArrowFix (StackT v c x y) where
type Fix (StackT v c x y) = Fix (Underlying (StackT v c) x y)--StackT v (Fix c ([v],x) ([v],y))
......@@ -31,6 +31,7 @@ import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Trans
import Control.Arrow.Environment
import Control.Arrow.Stack
import Control.Arrow.Store
import Control.Arrow.Except
import Control.Arrow.Reader
......@@ -45,7 +46,7 @@ newtype ValueT val c x y = ValueT { runValueT :: c x y }
deriving (Profunctor,Category,Arrow,ArrowChoice, ArrowConst r,
ArrowFrame frame, ArrowEnv var val', ArrowLetRec var val', ArrowStore addr val',
ArrowExcept exc,ArrowFail e,
ArrowReader r, ArrowState s, ArrowCont, ArrowCallSite ctx)
ArrowReader r, ArrowState s, ArrowCont, ArrowCallSite ctx, ArrowStack st)
instance (ArrowApply c, Profunctor c) => ArrowApply (ValueT val c) where
app = lift (app .# first coerce)
......
......@@ -19,5 +19,5 @@ extra-deps:
- git: https://github.com/svenkeidel/husk-scheme/
commit: ca59598b11065eb29a45af7ffca27fc42a49abe5
- git: https://gitlab.rlp.net/plmz/external/haskell-wasm.git
commit: 0c1cf172abda013099b46549ede9ea2c1aa84b7e
commit: 9e764fb16d7a1f44ce031f491b176096b9a799f4
- knob-0.1.1
......@@ -16,6 +16,7 @@ dependencies:
- unordered-containers
- wasm
- vector
- bytestring
library:
ghc-options: -Wall
......
{-# LANGUAGE Arrows #-}
--{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module ConcreteInterpreter where
import GenericInterpreter hiding (eval,evalNumericInst,evalVariableInstr,evalParametricInst,invokeExported)
import qualified GenericInterpreter as Generic
--import Stack
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Frame
import Control.Arrow.Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store
import qualified Control.Arrow.Trans as Trans
import Control.Arrow.WasmStore
import Control.Arrow.Transformer.Kleisli
import Control.Arrow.Transformer.Stack
import Control.Arrow.Trans
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.Value
import Control.Arrow.Transformer.Concrete.Failure
import Control.Arrow.Transformer.Concrete.Frame
import Control.Arrow.Transformer.Concrete.Except
import Control.Arrow.Transformer.Concrete.WasmStore
import Control.Arrow.Transformer.State
import Control.Category
import Data.Concrete.Error
import qualified Data.Function as Function
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Text.Lazy (Text)
import Data.Vector (Vector, (!), (//))
import qualified Data.Vector as Vec
import Data.Word
import Language.Wasm.Interpreter (ModuleInstance,emptyStore,emptyImports)
import qualified Language.Wasm.Interpreter as Wasm
import Language.Wasm.Structure hiding (exports)
import Language.Wasm.Validate (ValidModule)
import Numeric.Natural (Natural)
import System.IO.Unsafe (unsafePerformIO)
-- memory instance: vec(byte) + optional max size
-- bytes are modeled as Word8
-- addresses are modeled as Word32
--newtype WasmMemoryT c x y = WasmMemoryT (StateT (Vector Word8) c x y)
-- deriving (Profunctor, Category, Arrow, ArrowChoice, ArrowLift,
-- ArrowFail e, ArrowExcept e, ArrowConst r, ArrowStore var' val', ArrowRun, ArrowFrame fd val,
-- ArrowStack st, ArrowState (Vector Word8), ArrowReader r, ArrowWasmStore v2)
--
--instance ArrowTrans (WasmMemoryT) where
-- -- lift' :: c x y -> WasmStoreT v c x y
-- lift' arr = WasmMemoryT (lift' arr)
--
--
--instance (ArrowChoice c, Profunctor c) => ArrowMemory Word32 (Vector Word8) (WasmMemoryT c) where
-- memread sCont eCont = proc (addr, size, x) -> do
-- vec <- get -< ()
-- let addrI = fromIntegral addr
-- case (addrI+size <= length vec) of
-- True -> do
-- let content = Vec.slice addrI size vec
-- sCont -< (content,x)
-- False -> eCont -< x
-- memstore sCont eCont = proc (addr, content, x) -> do
-- vec <- get -< ()
-- let addrI = fromIntegral addr
-- let size = length content
-- case (addrI+size <= length vec) of
-- True -> do
-- let ind = Vec.enumFromN addrI size
-- put -< (Vec.update_ vec ind content)
-- sCont -< x
-- False -> eCont -< x
--
--instance (Arrow c, Profunctor c) => ArrowMemAddress Value Natural Word32 (WasmMemoryT c) where
-- memaddr = proc (Value (Wasm.VI32 base), off) -> returnA -< (base+ (fromIntegral off))
--
--instance ArrowSerialize Value (Vector Word8) ValueType LoadType StoreType (WasmMemoryT c) where
--
--instance ArrowMemSizable Value (WasmMemoryT c) where
--
--instance ArrowFix (Underlying (WasmMemoryT c) x y) => ArrowFix (WasmMemoryT c x y) where
-- type Fix (WasmMemoryT c x y) = Fix (Underlying (WasmMemoryT c) x y)
--
--
instance (ArrowChoice c) => IsVal Value (ValueT Value c) where
i32const = proc w32 -> returnA -< Value $ Wasm.VI32 w32
i64const = proc w64 -> returnA -< Value $ Wasm.VI64 w64
iBinOp = proc (bs,op,Value v1,Value v2) ->
case bs of
BS32 -> do
case op of
IAdd -> returnA -< Just $ Value $ addVal v1 v2
iRelOp = proc (bs,op,Value v1, Value v2) ->
case bs of
BS32 -> do
case op of
IEq -> returnA -< Value $ if v1 == v2 then (Wasm.VI32 1) else (Wasm.VI32 0)
BS64 -> do
case op of
IEq -> returnA -< Value $ if v1 == v2 then (Wasm.VI32 1) else (Wasm.VI32 0)
i32ifNeqz f g = proc (v, x) -> do
case v of
Value (Wasm.VI32 0) -> g -< x
Value (Wasm.VI32 _) -> f -< x
_ -> returnA -< error "validation failure"
ifHasType f g = proc (v,t,x) -> do
case (v,t) of
(Value (Wasm.VI32 _), I32) -> f -< x
(Value (Wasm.VI64 _), I64) -> f -< x
(Value (Wasm.VF32 _), F32) -> f -< x
(Value (Wasm.VF64 _), F64) -> f -< x
_ -> g -< x
addVal :: Wasm.Value -> Wasm.Value -> Wasm.Value
addVal (Wasm.VI32 v1) (Wasm.VI32 v2) = Wasm.VI32 $ v1 + v2
evalNumericInst :: (Instruction Natural) -> [Value] -> Error (Exc Value) Value
evalNumericInst inst stack =
snd $ Trans.run
(Generic.evalNumericInst ::
ValueT Value
(ExceptT (Exc Value)
(StackT Value
(->))) (Instruction Natural) Value) (stack,inst)
--type TransStack = FrameT FrameData Value (StackT Value (->))
--
evalVariableInst :: (Instruction Natural) -> [Value] -> FrameData -> Vector Value
-> WasmStore Value -> Int -> ([Value], (Vector Value, (WasmStore Value, ())))
evalVariableInst inst stack fd locals store currentMem =
Trans.run
(Generic.evalVariableInst ::
WasmStoreT Value
(FrameT FrameData Value
(StackT Value
(->))) (Instruction Natural) ()) (stack, (locals, (fd,(store, (currentMem,inst)))))
evalParametricInst :: (Instruction Natural) -> [Value] -> ([Value], ())
evalParametricInst inst stack =
Trans.run
(Generic.evalParametricInst ::
ValueT Value
(StackT Value
(->)) (Instruction Natural) ()) (stack,inst)
eval :: [Instruction Natural] -> [Value] -> Generic.LabelArities -> Vector Value -> FrameData ->
WasmStore Value -> Int ->
([Value], -- stack
Error (Generic.Exc Value)
(Vector Value, -- state of FrameT
(WasmStore Value, -- state of WasmStoreT
())))
eval inst stack r locals fd wasmStore currentMem =
let ?fixpointAlgorithm = Function.fix in
Trans.run
(Generic.eval ::
ValueT Value
(WasmStoreT Value
(FrameT FrameData Value
(ReaderT Generic.LabelArities
(ExceptT (Generic.Exc Value)
(StackT Value
(->)))))) [Instruction Natural] ()) (stack,(r,(locals,(fd,(wasmStore,(currentMem,inst))))))
invokeExported :: WasmStore Value
-> ModuleInstance
-> Text
-> [Value]
-> Error
[Char]
(Vector Value,
(WasmStore Value, Error (Exc Value) ([Value], [Value])))
invokeExported store modInst funcName args =
let ?fixpointAlgorithm = Function.fix in
Trans.run
(Generic.invokeExported ::
ValueT Value
(ReaderT Generic.LabelArities
(StackT Value
(ExceptT (Generic.Exc Value)
(WasmStoreT Value
(FrameT FrameData Value
(FailureT String
(->))))))) (Text, [Value]) [Value]) (Vec.empty,((0,modInst),(store,(0,([],(Generic.LabelArities [],(funcName,args)))))))
instantiate :: ValidModule -> IO (Either String (ModuleInstance, WasmStore Value))
instantiate valMod = do
res <- Wasm.instantiate emptyStore emptyImports valMod
case res of
Right (modInst, store) -> return $ Right $ (modInst, storeToWasmStore store)
Left e -> return $ Left e
where
storeToWasmStore (Wasm.Store funcI tableI memI globalI) =
WasmStore (Vec.map convertFuncs funcI)
(Vec.map TableInst tableI)
(Vec.map convertMem memI)
(convertGlobals globalI)
convertFuncs (Wasm.FunctionInstance t m c) = FuncInst t m c
convertFuncs (Wasm.HostInstance t _) = HostInst t
convertMem (Wasm.MemoryInstance _ _) = MemInst Vec.empty -- TODO
convertGlobals _ = Vec.empty -- TODO
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Frame where
import Prelude hiding ((.),read)
import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Except
import Control.Arrow.Fail
import Control.Arrow.Fix
import Control.Arrow.Reader as Reader
import Control.Arrow.Stack
import Control.Arrow.State
import Control.Arrow.Store
import Control.Arrow.Trans
import Control.Arrow.Transformer.State
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.Value
import Data.Monoidal (shuffle1)
import Data.Profunctor
import Data.Coerce
import Data.Vector
import Numeric.Natural (Natural)
-- | A frame has a fixed number of slots of type `v` and some arbitrar
-- | unchangeable frame data `fd`.
class ArrowFrame fd v c | c -> fd, c -> v where
-- | Runs a computation in a newly created frame given the frame data
-- | and the initial slot assignment.
inNewFrame :: c x y -> c (fd, [v], x) y
frameData :: c () fd
frameLookup :: c Natural v
frameUpdate :: c (Natural, v) ()
instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (StateT val c) where
-- inNewFrame :: (StateT val c) x y -> (StateT val c) (fd, [v], x) y
-- a :: (StateT val c) x y
-- unlift a :: Underlying (StateT val c) x y = c (val,x) (val,y)
-- inNewFrame :: c x y -> c (fd, [v], x) y
-- inNewFrame (unlift a) :: c (fd, [v], (val,x)) (val,y)
-- lift :: c (val, (fd, [v], x)) (val, y) -> StateT val c (fd, [v], x) y
inNewFrame a = lift $ shuffle (inNewFrame (unlift a))
where shuffle arr = proc (val, (fd, vs, x)) -> arr -< (fd, vs, (val,x))
frameData = lift' frameData
frameLookup = lift' frameLookup
frameUpdate = lift' frameUpdate
instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (ReaderT r c) where
inNewFrame (ReaderT a) = ReaderT $ shuffle (inNewFrame a)
where shuffle arr = proc (r, (fd, v, x)) -> arr -< (fd, v, (r,x))
frameData = lift' frameData
frameLookup = lift' frameLookup
frameUpdate = lift' frameUpdate
deriving instance (ArrowFrame fd v c) => ArrowFrame fd v (ValueT v2 c)
deriving instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (ExceptT e c)
instance (Monad f, Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (KleisliT f c) where
inNewFrame a = lift (inNewFrame (unlift a))
frameData = lift' frameData
frameLookup = lift' frameLookup
frameUpdate = lift' frameUpdate
deriving instance (Profunctor c, Arrow c, ArrowFrame fd v c) => ArrowFrame fd v (StackT s c)
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.MemAddress where
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
class ArrowMemAddress base off addr c where
memaddr :: c (base, off) addr
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ValueT val2 c)
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ExceptT e c)
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (KleisliT f c) where
-- TODO
deriving instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StackT v c)
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (StateT s c) where
-- TODO
instance (ArrowMemAddress base off addr c) => ArrowMemAddress base off addr (ReaderT r c) where
-- TODO
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Control.Arrow.MemSizable where
import Control.Arrow
import Control.Arrow.Trans
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
import Data.Profunctor
class ArrowMemSizable sz c where
memsize :: c () sz
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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}