[Git][ghc/ghc][wip/nr/wasm-translation-prototypes] experimental approach to calls
Norman Ramsey (@nrnrnr)
gitlab at gitlab.haskell.org
Sat Oct 8 19:16:03 UTC 2022
Norman Ramsey pushed to branch wip/nr/wasm-translation-prototypes at Glasgow Haskell Compiler / GHC
Commits:
fedf7e7a by Norman Ramsey at 2022-10-08T15:15:44-04:00
experimental approach to calls
- - - - -
2 changed files:
- compiler/GHC/Wasm/IR.hs
- compiler/GHC/Wasm/Tx.hs
Changes:
=====================================
compiler/GHC/Wasm/IR.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -5,16 +6,18 @@
{-# LANGUAGE TypeFamilies, StandaloneKindSignatures, PolyKinds #-}
{-# LANGUAGE TypeFamilies, ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-} -- for RevAppend
+{-# LANGUAGE TypeFamilyDependencies #-}
module GHC.Wasm.IR
( WasmIR(..), (<>), pattern WasmIf32, wasmReturn
, BrTableInterval(..), inclusiveInterval
, brTableLimit
+ , WasmLocal(..)
, WasmType(..), WasmTypeTag(..)
, TypeList(..)
- , RevAppend
+ , RevAppend, Reverse
, WasmFunctionType(..)
, SymName(..)
@@ -24,6 +27,7 @@ where
import GHC.Prelude
import Data.Kind
+import Data.String
import Data.Type.Equality
@@ -88,6 +92,9 @@ data WasmFunctionType pre post =
-- WebAssembly stack when the code runs, and `post` represents
-- the state of the stack on completion.
+newtype WasmLocal = WasmLocal Int
+
+
data WasmIR :: WasmType -> [WasmType] -> [WasmType] -> Type where
WasmPush :: WasmTypeTag t -> WasmIR bool stack (t ': stack) -> WasmIR bool stack (t ': stack)
@@ -134,19 +141,36 @@ data WasmIR :: WasmType -> [WasmType] -> [WasmType] -> Type where
-----
-- WasmCCall :: SymName -> WasmIR bool pre post -- completely untyped
- WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmIR bool (t : pre) pre
- WasmLocalGet :: WasmTypeTag t -> Int -> WasmIR bool pre (t : pre)
- WasmLocalSet :: WasmTypeTag t -> Int -> WasmIR bool (t : pre) pre
+-- WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmIR bool (t : pre) pre
+-- WasmLocalGet :: WasmTypeTag t -> Int -> WasmIR bool pre (t : pre)
+
+ WasmSetLocal :: WasmTypeTag t -> WasmLocal -> WasmIR bool (t : pre) pre
+
+ WasmCall :: TypeList argtys
+ -> TypeList restys
+ -> SymName
+ -> WasmIR bool (RevAppend argtys '[]) (RevAppend restys '[])
- WasmCallNoResults :: TypeList ts -> WasmIR bool (RevAppend ts stack) stack
+ WasmCallIndirect
+ :: WasmTypeTag t -- type of function value on stack
+ -> TypeList argtys
+ -> TypeList restys
+ -- call target hasn't been added yet
+ -> WasmIR bool (t : RevAppend argtys '[]) (RevAppend restys '[])
WasmNop :: WasmIR bool stack stack -- translation of empty list of expressions
+
type RevAppend :: forall a. [a] -> [a] -> [a]
type family RevAppend xs ys where
RevAppend '[] ys = ys
RevAppend (x:xs) ys = RevAppend xs (x : ys)
+type Reverse :: forall a . [a] -> [a]
+type family Reverse xs where
+ Reverse xs = RevAppend xs '[]
+
+
@@ -201,3 +225,5 @@ wasmReturn tag e = WasmPush tag e `WasmSeq` WasmReturnTop tag
newtype SymName = SymName FastString
+ deriving (Eq, IsString, Show) via FastString -- , Uniquable
+ deriving (Ord) via LexicalFastString
=====================================
compiler/GHC/Wasm/Tx.hs
=====================================
@@ -7,25 +7,34 @@
{-# LANGUAGE ImpredicativeTypes #-}
module GHC.Wasm.Tx
- ( tx
+ ( expr
, CG(..)
, WasmExpr
, WasmExprs
- , txs
+ , exprs
- , call
+ , node
+
+ , setLocals
+ , WasmLocal(..)
+
+ , WasmAction, WasmTopAction
)
where
import GHC.Prelude
+import Data.String
import Data.Type.Equality
import qualified GHC.Cmm.Type as CT
-import GHC.Cmm.Expr
+import GHC.Cmm.CLabel
+ import GHC.Cmm.Expr hiding (node)
import GHC.Cmm.Node
+import GHC.Platform
+import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain (assert)
import GHC.Wasm.IR
@@ -55,8 +64,13 @@ import GHC.Cmm.Dataflow.Block
-- property used in the prototype: the platform Boolean
-- type is discoverable.
+
class Monad (codegen bool) => CG bool codegen where
booleanWasmTypeTag :: codegen bool (WasmTypeTag bool)
+ cpsLocalReg :: LocalReg
+ -> (forall t . WasmTypeTag t -> WasmLocal -> codegen bool a)
+ -> codegen bool a
+
----------------------------------------------------------------
@@ -76,7 +90,7 @@ type WasmExpr bool t = (forall stack . WasmIR bool stack (t : stack))
-- Sound Type-Indexed Type Checker (Functional Pearl), Haskell
-- Symposium 2020 (https://doi.org/10.1145/3406088.3409015).
-tx :: CG bool codegen
+expr :: CG bool codegen
=> CmmExpr
-> (forall t . WasmTypeTag t -> WasmExpr bool t -> codegen bool a)
-> codegen bool a
@@ -84,10 +98,11 @@ tx :: CG bool codegen
-- The translation is organized as follows:
--
--- * The main translation function `tx` dispatches on the form of a
--- Cmm expression.
+-- * The main translation function `expr` dispatches on the form of
+-- a Cmm expression. (In general, a translation function is named
+-- after the thing it translates.)
--
--- * For every different type of Cmm operator, `tx` calls a
+-- * For every different type of Cmm operator, `expr` calls a
-- different auxiliary function: `wasmUnary`, `wasmBinary`,
-- `wasmCompare`, and so on.
--
@@ -96,12 +111,12 @@ tx :: CG bool codegen
-- that each type of operator might require a Haskell translation
-- function of a different type. But it's a bit irksome.)
--
--- * Each auxiliary function calls back into `tx` to translate
+-- * Each auxiliary function calls back into `expr` to translate
-- operands, if any, then composes the resulting code.
--
-- All functions are CPS.
-tx expr k =
+expr expr k =
case expr of
CmmLit (CmmInt n w) -> wasmNullaryInt w (flip WasmInt n) k
CmmLit (CmmFloat x w) -> wasmNullaryFloat w (flip WasmFloat x) k
@@ -169,7 +184,7 @@ wasmNullaryFloat w operator k =
withFloatWidthTag w $ \tag -> k tag (operator tag)
wasmUnary w [e] operator k =
- tx e $ \tag code -> assert (tag `hasWidth` w) $ k tag (code <> operator tag)
+ expr e $ \tag code -> assert (tag `hasWidth` w) $ k tag (code <> operator tag)
wasmUnary _ _ _ _ = panic "wrong number of operands to unary operator in Cmm"
wasmBinary w es operator k =
@@ -193,8 +208,8 @@ binaryCPS
-> codegen bool a
binaryCPS [e1, e2] k = -- would dearly love to use do notation here
- tx e1 $ \tag1 code1 ->
- tx e2 $ \tag2 code2 ->
+ expr e1 $ \tag1 code1 ->
+ expr e2 $ \tag2 code2 ->
case tag1 `testEquality` tag2 of -- mandatory check
Just Refl -> k tag1 code1 code2
Nothing -> panic "ill-typed Cmm"
@@ -227,24 +242,71 @@ withFloatWidthTag w _ = panic $ "width " ++ show w ++ " not supported on wasm ta
type WasmExprs bool ts = (forall stack . WasmIR bool stack (RevAppend ts stack))
-txs :: CG bool codegen
+-- | Translate a list of Cmm expressions
+exprs :: CG bool codegen
=> [CmmExpr]
-> (forall ts . TypeList ts -> WasmExprs bool ts -> codegen bool a)
-> codegen bool a
-txs [] k = k TypeListNil WasmNop
-txs (e:es) k = -- first expression is oldest on stack
- txs es $ \ts codes ->
- tx e $ \t code ->
+exprs [] k = k TypeListNil WasmNop
+exprs (e:es) k = -- first expression is oldest on stack
+ exprs es $ \ts codes ->
+ expr e $ \t code ->
k (TypeListCons t ts) (code <> codes)
type WasmAction bool = (forall stack . WasmIR bool stack stack)
+type WasmTopAction bool = (WasmIR bool '[] '[])
+
+-- | Translate an open-open Cmm node (action)
-call :: CG bool codegen
+node :: CG bool codegen
=> CmmNode O O
- -> (WasmAction bool -> codegen bool a)
+ -> (WasmTopAction bool -> codegen bool a)
+ -- using WasmAction here, I can't get the code to typecheck
+ -- (non-injectivity of RevAppend)
-> codegen bool a
-call (CmmUnsafeForeignCall _target [] arguments) k =
+node (CmmUnsafeForeignCall (ForeignTarget target _cconv) results arguments) k =
-- ran out of time to deal with result registers
- txs arguments $ \ts codes ->
- k (codes <> WasmCallNoResults ts)
-call _ _ = panic "more cases needed"
+ exprs arguments $ \argtys arg_codes ->
+ localRegs results $ \restys xs ->
+ wasmCall argtys restys target $ \code ->
+ k (arg_codes <> code <> setLocals restys xs)
+node _ _ = panic "more cases needed"
+
+-- | Generate a Wasm call to a Cmm expression
+wasmCall :: CG bool codegen
+ => TypeList argtypes
+ -> TypeList restypes
+ -> CmmExpr
+ -> (WasmIR bool (Reverse argtypes) (Reverse restypes) -> codegen bool a)
+ -> codegen bool a
+wasmCall argtypes restypes (CmmLit (CmmLabel callee)) k =
+ k (WasmCall argtypes restypes (symNameFromCLabel callee))
+wasmCall argtypes restypes e k =
+ expr e $ \t code -> k (code <> WasmCallIndirect t argtypes restypes)
+
+
+-- | set the given local variables from values on the evaluation stack
+setLocals :: TypeList ts -> [WasmLocal] -> WasmIR bool (RevAppend ts stack) stack
+setLocals TypeListNil [] = WasmNop
+setLocals (TypeListCons t ts) (x:xs) = setLocals ts xs <> WasmSetLocal t x
+setLocals _ _ = panic "this can't happen -- rewrite code to make it obvious?"
+
+
+-- | use the CG monad to find the types and locations of local registers
+localRegs :: CG bool codegen
+ => [LocalReg]
+ -> (forall ts . TypeList ts -> [WasmLocal] -> codegen bool a)
+ -> codegen bool a
+localRegs [] k = k TypeListNil []
+localRegs (r:rs) k =
+ localRegs rs $ \ts xs ->
+ cpsLocalReg r $ \t x ->
+ k (TypeListCons t ts) (x:xs)
+
+
+
+symNameFromCLabel :: CLabel -> SymName
+symNameFromCLabel lbl =
+ fromString $
+ showSDocOneLine defaultSDocContext {sdocStyle = PprCode AsmStyle} $
+ pprCLabel genericPlatform AsmStyle lbl
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fedf7e7a9f2854d1d8990a94c14eb62759a9dc09
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fedf7e7a9f2854d1d8990a94c14eb62759a9dc09
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/20221008/161fc6bf/attachment-0001.html>
More information about the ghc-commits
mailing list