[Git][ghc/ghc][wip/nr/wasm-translation-prototypes] add experiment on translating calls

[Norman Ramsey (@nrnrnr)]

Norman Ramsey pushed to branch wip/nr/wasm-translation-prototypes at Glasgow Haskell Compiler / GHC


Commits:
bc4d6c88 by Norman Ramsey at 2022-10-08T13:22:14-04:00
add experiment on translating calls

- - - - -


2 changed files:

- compiler/GHC/Wasm/IR.hs
- compiler/GHC/Wasm/Tx.hs


Changes:

=====================================
compiler/GHC/Wasm/IR.hs
=====================================
@@ -2,15 +2,19 @@
 {-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies, StandaloneKindSignatures, PolyKinds #-}
 {-# LANGUAGE TypeFamilies, ConstraintKinds #-}
+{-# LANGUAGE UndecidableInstances #-} -- for RevAppend
 
 module GHC.Wasm.IR
   ( WasmIR(..), (<>), pattern WasmIf32, wasmReturn
   , BrTableInterval(..), inclusiveInterval
   , brTableLimit
 
+
   , WasmType(..), WasmTypeTag(..)
   , TypeList(..)
+  , RevAppend
   , WasmFunctionType(..)
 
   , SymName(..)
@@ -129,11 +133,22 @@ data WasmIR :: WasmType -> [WasmType] -> [WasmType] -> Type where
 
   -----
 
-  WasmCCall :: SymName -> WasmIR bool pre post -- completely untyped
+--  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
 
+  WasmCallNoResults :: TypeList ts -> WasmIR bool (RevAppend ts stack) stack
+
+  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)
+
+
+
 
 
 data BrTableInterval


=====================================
compiler/GHC/Wasm/Tx.hs
=====================================
@@ -3,11 +3,18 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies, StandaloneKindSignatures, PolyKinds #-}
+{-# LANGUAGE ImpredicativeTypes #-}
 
 module GHC.Wasm.Tx
   ( tx
   , CG(..)
   , WasmExpr
+
+  , WasmExprs
+  , txs
+
+  , call
   )
 
 where
@@ -18,10 +25,13 @@ import Data.Type.Equality
 
 import qualified GHC.Cmm.Type as CT
 import GHC.Cmm.Expr
+import GHC.Cmm.Node
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain (assert)
 import GHC.Wasm.IR
 
+import GHC.Cmm.Dataflow.Block
+
 ----------------------------------------------------------------
 ---
 ---     Overview
@@ -210,3 +220,31 @@ withFloatWidthTag :: CT.Width -> (forall t . WasmTypeTag t -> a) -> a
 withFloatWidthTag CT.W32 k = k TagF32
 withFloatWidthTag CT.W64 k = k TagF64
 withFloatWidthTag w _ = panic $ "width " ++ show w ++ " not supported on wasm target"
+
+
+----------------------------------------------------------------
+-- new and experimental
+
+type WasmExprs bool ts = (forall stack . WasmIR bool stack (RevAppend ts stack))
+
+txs :: 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 ->
+      k (TypeListCons t ts) (code <> codes)
+
+type WasmAction bool = (forall stack . WasmIR bool stack stack)
+
+call :: CG bool codegen
+     => CmmNode O O
+     -> (WasmAction bool -> codegen bool a)
+     -> codegen bool a
+call (CmmUnsafeForeignCall _target [] arguments) k =
+    -- ran out of time to deal with result registers
+    txs arguments $ \ts codes ->
+      k (codes <> WasmCallNoResults ts)
+call _ _ = panic "more cases needed"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc4d6c88c7f597a817a7bc318bfdffbb44620a6c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc4d6c88c7f597a817a7bc318bfdffbb44620a6c
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/ef7ffcf4/attachment-0001.html>