GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

replace several type args with one context

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-29 10:08:13 -07:00
parent 86130221e7
commit 6d96f31b53
1 changed files with 84 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/AST.hs
+84 -48
View File
@@ -2,11 +2,9 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
module Language.Wasm.AST ( module Language.Wasm.AST (
@@ -75,6 +73,10 @@ type family LabelAsArgs (label :: Maybe ValueType) :: [VType] where
LabelAsArgs (Just val) = '[Val val] LabelAsArgs (Just val) = '[Val val]
LabelAsArgs Nothing = '[] LabelAsArgs Nothing = '[]
type family AsVType (values :: [ValueType]) :: [VType] where
AsVType (v : vs) = Val v : AsVType vs
AsVType '[] = '[]
class KnownNats ns where class KnownNats ns where
natVals :: Proxy ns -> [Integer] natVals :: Proxy ns -> [Integer]
@@ -87,70 +89,104 @@ instance (KnownNat n, KnownNats ns) => KnownNats (n : ns) where
dup :: Proxy (n : ns) -> (Proxy n, Proxy ns) dup :: Proxy (n : ns) -> (Proxy n, Proxy ns)
dup _ = (Proxy, Proxy) dup _ = (Proxy, Proxy)
data InstrSeq (stack :: [VType]) (locals :: [VType]) (globals :: [GlobalType]) (labels :: [Maybe ValueType]) where data Ctx (locals :: [VType]) (globals :: [GlobalType]) (labels :: [Maybe ValueType]) (returns :: [ValueType])
Empty :: InstrSeq '[] locals globals labels
Unreachable :: InstrSeq stack locals globals labels -> InstrSeq '[Any] locals globals labels type family GetLocals ctx :: [VType] where
Nop :: InstrSeq stack locals globals labels -> InstrSeq stack locals globals labels GetLocals (Ctx locals globals labels returns) = locals
type family GetGlobals ctx :: [GlobalType] where
GetGlobals (Ctx locals globals labels returns) = globals
type family GetLabels ctx :: [Maybe ValueType] where
GetLabels (Ctx locals globals labels returns) = labels
type family WithLabel ctx (label :: Maybe ValueType) where
WithLabel (Ctx locals globals labels returns) label = Ctx locals globals (label : labels) returns
type family GetReturns ctx :: [ValueType] where
GetReturns (Ctx locals globals labels returns) = returns
data InstrSeq (stack :: [VType]) ctx where
Empty :: InstrSeq '[] ctx
Unreachable :: InstrSeq stack ctx -> InstrSeq '[Any] ctx
Nop :: InstrSeq stack ctx -> InstrSeq stack ctx
Block :: (IsLabelMatch label result ~ True) => Block :: (IsLabelMatch label result ~ True) =>
InstrSeq result locals globals (label : labels) -> Proxy (label :: Maybe ValueType) ->
InstrSeq stack locals globals labels -> InstrSeq result (WithLabel ctx label) ->
InstrSeq (result :++ stack) locals globals labels InstrSeq stack ctx ->
InstrSeq (result :++ stack) ctx
Loop :: (IsLabelMatch label result ~ True) => Loop :: (IsLabelMatch label result ~ True) =>
InstrSeq result locals globals (label : labels) -> Proxy (label :: Maybe ValueType) ->
InstrSeq stack locals globals labels -> InstrSeq result (WithLabel ctx label) ->
InstrSeq (result :++ stack) locals globals labels InstrSeq stack ctx ->
InstrSeq (result :++ stack) ctx
If :: (IsLabelMatch label result ~ True, MatchStack '[Val I32] stack ~ True) => If :: (IsLabelMatch label result ~ True, MatchStack '[Val I32] stack ~ True) =>
InstrSeq result locals globals (label : labels) -> Proxy (label :: Maybe ValueType) ->
InstrSeq result locals globals (label : labels) -> InstrSeq result (WithLabel ctx label) ->
InstrSeq stack locals globals labels -> InstrSeq result (WithLabel ctx label) ->
InstrSeq (Consume '[Val I32] stack result) locals globals labels InstrSeq stack ctx ->
Br :: (KnownNat label, MatchStack (LabelAsArgs (labels :!! label)) stack ~ True) => InstrSeq (Consume '[Val I32] stack result) ctx
Br :: (KnownNat label, MatchStack (LabelAsArgs ((GetLabels ctx) :!! label)) stack ~ True) =>
Proxy label -> Proxy label ->
InstrSeq stack locals globals lables -> InstrSeq stack ctx ->
InstrSeq '[Any] locals globals labels InstrSeq '[Any] ctx
BrIf :: (KnownNat label, MatchStack ((LabelAsArgs (labels :!! label)) :++ '[Val I32]) stack ~ True) => BrIf :: (KnownNat label, MatchStack ((LabelAsArgs ((GetLabels ctx) :!! label)) :++ '[Val I32]) stack ~ True) =>
Proxy label -> Proxy label ->
InstrSeq stack locals globals lables -> InstrSeq stack ctx ->
InstrSeq (Consume ((LabelAsArgs (labels :!! label)) :++ '[Val I32]) stack (LabelAsArgs (labels :!! label))) locals globals labels InstrSeq (Consume ((LabelAsArgs ((GetLabels ctx) :!! label)) :++ '[Val I32]) stack (LabelAsArgs ((GetLabels ctx) :!! label))) ctx
BrTable :: (KnownNat defaultLabel, KnownNats localLabels, MatchStack ((LabelAsArgs (labels :!! defaultLabel)) :++ '[Val I32]) stack ~ True) => BrTable :: (
KnownNat defaultLabel,
KnownNats localLabels,
MatchStack ((LabelAsArgs ((GetLabels ctx) :!! defaultLabel)) :++ '[Val I32]) stack ~ True
) =>
Proxy (localLabels :: [Nat]) -> Proxy (localLabels :: [Nat]) ->
Proxy defaultLabel -> Proxy defaultLabel ->
InstrSeq stack locals globals lables -> InstrSeq stack ctx ->
InstrSeq (Consume ((LabelAsArgs (labels :!! defaultLabel)) :++ '[Val I32]) stack '[Any]) locals globals labels InstrSeq (Consume ((LabelAsArgs ((GetLabels ctx) :!! defaultLabel)) :++ '[Val I32]) stack '[Any]) ctx
Drop :: InstrSeq (any : stack) locals globals labels -> InstrSeq stack locals globals labels Return :: (MatchStack (AsVType (GetReturns ctx)) stack ~ True) =>
InstrSeq stack ctx ->
InstrSeq (Consume (AsVType (GetReturns ctx)) stack '[Any]) ctx
-- Call :: (MatchStack (AsVType returns) stack ~ True) =>
-- Proxy function ->
-- InstrSeq stack locals globals lables returns ->
Drop :: InstrSeq (any : stack) ctx -> InstrSeq stack ctx
Select :: (MatchStack '[Var, Var, Val I32] stack ~ True) => Select :: (MatchStack '[Var, Var, Val I32] stack ~ True) =>
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[Var, Var, Val I32] stack '[Var]) locals globals labels InstrSeq (Consume '[Var, Var, Val I32] stack '[Var]) ctx
GetLocal :: (KnownNat local) => GetLocal :: (KnownNat local) =>
Proxy local -> Proxy local ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq ((locals :!! local) : stack) locals globals labels InstrSeq (((GetLocals ctx) :!! local) : stack) ctx
SetLocal :: (KnownNat local, MatchStack '[locals :!! local] stack ~ True) => SetLocal :: (KnownNat local, MatchStack '[(GetLocals ctx) :!! local] stack ~ True) =>
Proxy local -> Proxy local ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[locals :!! local] stack '[]) locals globals labels InstrSeq (Consume '[(GetLocals ctx) :!! local] stack '[]) ctx
TeeLocal :: (KnownNat local, MatchStack '[locals :!! local] stack ~ True) => TeeLocal :: (KnownNat local, MatchStack '[(GetLocals ctx) :!! local] stack ~ True) =>
Proxy local -> Proxy local ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[locals :!! local] stack '[locals :!! local]) locals globals labels InstrSeq (Consume '[(GetLocals ctx) :!! local] stack '[(GetLocals ctx) :!! local]) ctx
GetGlobal :: (KnownNat global) => GetGlobal :: (KnownNat global) =>
Proxy global -> Proxy global ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq ((GetGlobalType (globals :!! global)) : stack) locals globals labels InstrSeq ((GetGlobalType ((GetGlobals ctx) :!! global)) : stack) ctx
SetGlobal :: (KnownNat global, MatchStack '[GetGlobalType (globals :!! global)] stack ~ True, IsMutable (globals :!! global) ~ True) => SetGlobal :: (
KnownNat global,
MatchStack '[GetGlobalType ((GetGlobals ctx) :!! global)] stack ~ True,
IsMutable ((GetGlobals ctx) :!! global) ~ True
) =>
Proxy global -> Proxy global ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[GetGlobalType (globals :!! global)] stack '[]) locals globals labels InstrSeq (Consume '[GetGlobalType ((GetGlobals ctx) :!! global)] stack '[]) ctx
I32Const :: InstrSeq stack locals globals labels -> InstrSeq (Val I32 : stack) locals globals labels I32Const :: InstrSeq stack ctx -> InstrSeq (Val I32 : stack) ctx
I32UnOp :: (MatchStack '[Val I32] stack ~ True) => I32UnOp :: (MatchStack '[Val I32] stack ~ True) =>
IUnOp -> IUnOp ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[Val I32] stack '[Val I32]) locals globals labels InstrSeq (Consume '[Val I32] stack '[Val I32]) ctx
I32BinOp :: (MatchStack '[Val I32, Val I32] stack ~ True) => I32BinOp :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
IBinOp -> IBinOp ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) locals globals labels InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) ctx
I32RelOp :: (MatchStack '[Val I32, Val I32] stack ~ True) => I32RelOp :: (MatchStack '[Val I32, Val I32] stack ~ True) =>
IRelOp -> IRelOp ->
InstrSeq stack locals globals labels -> InstrSeq stack ctx ->
InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) locals globals labels InstrSeq (Consume '[Val I32, Val I32] stack '[Val I32]) ctx