[Git][ghc/ghc][wip/nr/wasm-translation-prototypes] 3 commits: convo with Cheng, won't compile
Norman Ramsey (@nrnrnr)
gitlab at gitlab.haskell.org
Wed Oct 5 18:30:14 UTC 2022
Norman Ramsey pushed to branch wip/nr/wasm-translation-prototypes at Glasgow Haskell Compiler / GHC
Commits:
5697b10a by Norman Ramsey at 2022-10-05T10:41:32-04:00
convo with Cheng, won't compile
- - - - -
88ce88a4 by Norman Ramsey at 2022-10-05T13:14:46-04:00
started migrating to WasmExpr
- - - - -
32129de7 by Norman Ramsey at 2022-10-05T14:29:05-04:00
change prototype to use `WasmExpr bool t`
with universally quantified stack
- - - - -
2 changed files:
- compiler/GHC/Wasm/IR.hs
- compiler/GHC/Wasm/Tx.hs
Changes:
=====================================
compiler/GHC/Wasm/IR.hs
=====================================
@@ -134,10 +134,6 @@ data WasmIR :: WasmType -> [WasmType] -> [WasmType] -> Type where
WasmLocalGet :: WasmTypeTag t -> Int -> WasmIR bool pre (t : pre)
WasmLocalSet :: WasmTypeTag t -> Int -> WasmIR bool (t : pre) pre
- WasmLift :: (pre' ~ (t : pre), post' ~ (t : post)) =>
- WasmTypeTag t -> WasmIR bool pre post -> WasmIR bool pre' post'
-
-
data BrTableInterval
=====================================
compiler/GHC/Wasm/Tx.hs
=====================================
@@ -7,21 +7,39 @@
module GHC.Wasm.Tx
( tx
, CG(..)
+ , WasmExpr(..)
)
+
where
import GHC.Prelude
import Data.Type.Equality
---import Data.Kind
import qualified GHC.Cmm.Type as CT
import GHC.Cmm.Expr
---import GHC.Data.FastString
---import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic
import GHC.Wasm.IR
+----------------------------------------------------------------
+
+newtype WasmExpr bool t =
+ WasmExpr (forall pre . WasmIR bool pre (t : pre))
+
+apply1 :: (forall stack . WasmIR bool (t : stack) (t' : stack))
+ -> WasmExpr bool t
+ -> WasmExpr bool t'
+apply1 operator (WasmExpr code) = WasmExpr (code <> operator)
+
+apply2 :: (forall stack . WasmIR bool (t2 : t1 : stack) (t : stack))
+ -> WasmExpr bool t1
+ -> WasmExpr bool t2
+ -> WasmExpr bool t
+apply2 operator (WasmExpr code1) (WasmExpr code2) =
+ WasmExpr (code1 <> code2 <> operator)
+
+----------------------------------------------------------------
+
class Monad (codegen bool) => CG bool codegen where
-- platformWordSize :: m Int
-- asType :: WasmTypeTag t -> m () -- check that type is consistent
@@ -29,65 +47,90 @@ class Monad (codegen bool) => CG bool codegen where
-- asInt :: WasmTypeTag t -> m () -- insist on the platofrm integer type
booleanWasmTypeTag :: codegen bool (WasmTypeTag bool)
+
+
tx :: CG bool codegen
- => CmmExpr
- -> (forall t . WasmTypeTag t -> WasmIR bool '[] (t : '[]) -> codegen bool r)
- -> codegen bool r
- -- combines type checking and translation
+ => CmmExpr
+ -> (forall t . WasmTypeTag t -> WasmExpr bool t -> codegen bool r)
+ -> codegen bool r
+ -- combines translation with some type checking
+
tx expr k =
case expr of
- CmmLit (CmmInt n w) -> withIntWidthTag w $ \tag -> k tag (WasmInt tag n)
- CmmLit (CmmFloat x w) -> withFloatWidthTag w $ \tag -> k tag (WasmFloat tag x)
+ CmmLit (CmmInt n w) -> wasmNullaryInt w (flip WasmInt n) k
+ CmmLit (CmmFloat x w) -> wasmNullaryFloat w (flip WasmFloat x) k
+
+ CmmMachOp (MO_Not w) es -> wasmUnary w es WasmNot k
CmmMachOp (MO_Add w) es -> wasmBinary w es WasmAdd k
CmmMachOp (MO_Sub w) es -> wasmBinary w es WasmSub k
CmmMachOp (MO_S_Ge w) es -> wasmCompare w es WasmS_Ge k
- CmmMachOp (MO_Not w) es -> wasmUnary w es WasmNot k
_ -> panic "unimplemented"
-wasmBinary :: CG bool codegen
- => CT.Width
- -> [CmmExpr]
- -> (forall t . WasmTypeTag t -> WasmIR bool (t : t : '[]) (t : '[]))
- -> (forall t . WasmTypeTag t -> WasmIR bool '[] (t : '[]) -> codegen bool r)
- -> codegen bool r
-
-wasmCompare :: forall bool codegen r . CG bool codegen
- => CT.Width
- -> [CmmExpr]
- -> (forall t . WasmTypeTag t -> WasmIR bool (t : t : '[]) (bool : '[]))
- -> ( WasmTypeTag bool -> WasmIR bool '[] (bool : '[]) -> codegen bool r)
- -> codegen bool r
+wasmNullaryInt, wasmNullaryFloat ::
+ CG bool codegen
+ => CT.Width
+ -> (forall t stack . WasmTypeTag t -> WasmIR bool (stack) (t : stack))
+ -> (forall t . WasmTypeTag t -> WasmExpr bool t -> codegen bool r)
+ -> codegen bool r
wasmUnary :: CG bool codegen
=> CT.Width
-> [CmmExpr]
- -> (forall t . WasmTypeTag t -> WasmIR bool (t : '[]) (t : '[]))
- -> (forall t . WasmTypeTag t -> WasmIR bool '[] (t : '[]) -> codegen bool r)
+ -> (forall t pre . WasmTypeTag t -> WasmIR bool (t : pre) (t : pre))
+ -> (forall t . WasmTypeTag t -> WasmExpr bool t -> codegen bool r)
-> codegen bool r
+wasmBinary ::
+ CG bool codegen
+ => CT.Width
+ -> [CmmExpr]
+ -> (forall t stack . WasmTypeTag t -> WasmIR bool (t : t : stack) (t : stack))
+ -> (forall t . WasmTypeTag t -> WasmExpr bool t -> codegen bool r)
+ -> codegen bool r
+
+
+wasmCompare ::
+ forall bool codegen r . CG bool codegen
+ => CT.Width
+ -> [CmmExpr]
+ -> (forall t stack . WasmTypeTag t -> WasmIR bool (t : t : stack) (bool : stack))
+ -> (WasmTypeTag bool -> WasmExpr bool bool -> codegen bool r)
+ -> codegen bool r
+
+----------------------------------------------------------------
+
+wasmNullaryInt w operator k =
+ withIntWidthTag w $ \tag -> k tag (WasmExpr $ operator tag)
+
+
+wasmNullaryFloat w operator k =
+ withFloatWidthTag w $ \tag -> k tag (WasmExpr $ operator tag)
+
+wasmUnary w [e] operator k =
+ tx e $ \tag code -> checkTagWidth tag w $ k tag (apply1 (operator tag) code)
+wasmUnary _ _ _ _ = panic "wrong number of operands to unary operator in Cmm"
wasmBinary w es operator k =
binaryCPS es $ \tag code1 code2 ->
checkTagWidth tag w $ -- optional check
- k tag (code1 <> WasmLift tag code2 <> operator tag)
-
+ k tag (apply2 (operator tag) code1 code2)
wasmCompare w es operator k =
binaryCPS es $ \tag code1 code2 -> do
bool <- booleanWasmTypeTag
checkTagWidth bool w $
- k bool (code1 <> WasmLift tag code2 <> operator tag)
+ k bool (apply2 (operator tag) code1 code2)
binaryCPS
:: forall bool codegen a . CG bool codegen
=> [CmmExpr]
-> (forall t . WasmTypeTag t
- -> WasmIR bool '[] (t : '[])
- -> WasmIR bool '[] (t : '[])
+ -> WasmExpr bool t
+ -> WasmExpr bool t
-> codegen bool a)
-> codegen bool a
@@ -99,10 +142,6 @@ binaryCPS [e1, e2] k = -- would dearly love to use do notation here
Nothing -> panic "ill-typed Cmm"
binaryCPS _ _ = panic "wrong number of operands to binary operator in Cmm"
-wasmUnary w [e] operator k =
- tx e $ \tag code -> checkTagWidth tag w $ k tag (code <> operator tag)
-wasmUnary _ _ _ _ = panic "wrong number of operands to unary operator in Cmm"
-
----------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893c276e403e2eddcc458c373d541a4f2a7c80bf...32129de7652567f7cd6867a549af2bd08927bffd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893c276e403e2eddcc458c373d541a4f2a7c80bf...32129de7652567f7cd6867a549af2bd08927bffd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221005/e10be0cd/attachment-0001.html>
More information about the ghc-commits
mailing list