[Git][ghc/ghc][master] 2 commits: compiler: make WasmCodeGenM an instance of MonadUnique

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00
compiler: make WasmCodeGenM an instance of MonadUnique

- - - - -
05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00
compiler: apply cmm node-splitting for wasm backend

This patch applies cmm node-splitting for wasm32 NCG, which is
required when handling irreducible CFGs. Fixes #23237.

- - - - -


3 changed files:

- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/Wasm/Types.hs
- compiler/GHC/Wasm/ControlFlow/FromCmm.hs


Changes:

=====================================
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Types.ForeignCall
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.Map
+import GHC.Types.Unique.Supply
 import GHC.Utils.Outputable hiding ((<>))
 import GHC.Utils.Panic
 import GHC.Wasm.ControlFlow.FromCmm
@@ -1328,7 +1329,7 @@ lower_CmmUnsafeForeignCall_Drop ::
   [CmmActual] ->
   WasmCodeGenM w (WasmStatements w)
 lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do
-  ret_uniq <- wasmUniq
+  ret_uniq <- getUniqueM
   let ret_local = LocalReg ret_uniq ret_cmm_ty
   lower_CmmUnsafeForeignCall
     lbl
@@ -1528,9 +1529,11 @@ lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)
 lower_CmmGraph lbl g = do
   ty_word <- wasmWordTypeM
   platform <- wasmPlatformM
+  us <- getUniqueSupplyM
   body <-
     structuredControl
       platform
+      us
       (\_ -> lower_CmmExpr_Typed lbl ty_word)
       (lower_CmmActions lbl)
       g


=====================================
compiler/GHC/CmmToAsm/Wasm/Types.hs
=====================================
@@ -45,7 +45,6 @@ module GHC.CmmToAsm.Wasm.Types
     wasmStateM,
     wasmModifyM,
     wasmExecM,
-    wasmUniq,
   )
 where
 
@@ -466,10 +465,18 @@ wasmStateM = coerce . State
 wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
 wasmModifyM = coerce . modify
 
+wasmEvalM :: WasmCodeGenM w a -> WasmCodeGenState w -> a
+wasmEvalM (WasmCodeGenM s) = evalState s
+
 wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
 wasmExecM (WasmCodeGenM s) = execState s
 
-wasmUniq :: WasmCodeGenM w Unique
-wasmUniq = wasmStateM $
-  \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
-    (u, us) -> (# u, s {wasmUniqSupply = us} #)
+instance MonadUnique (WasmCodeGenM w) where
+  getUniqueSupplyM = wasmGetsM wasmUniqSupply
+  getUniqueM = wasmStateM $
+    \s at WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
+      (u, us) -> (# u, s {wasmUniqSupply = us} #)
+  getUniquesM = do
+    u <- getUniqueM
+    s <- WasmCodeGenM get
+    pure $ u:(wasmEvalM getUniquesM s)


=====================================
compiler/GHC/Wasm/ControlFlow/FromCmm.hs
=====================================
@@ -19,12 +19,13 @@ import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dominators
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Reducibility
 import GHC.Cmm.Switch
 
 import GHC.CmmToAsm.Wasm.Types
 
 import GHC.Platform
-
+import GHC.Types.Unique.Supply
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
@@ -140,15 +141,19 @@ emptyPost _ = False
 structuredControl :: forall expr stmt m .
                      Applicative m
                   => Platform  -- ^ needed for offset calculation
+                  -> UniqSupply
                   -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
                   -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
                   -> CmmGraph -- ^ CFG to be translated
                   -> m (WasmControl stmt expr '[] '[ 'I32])
-structuredControl platform txExpr txBlock g =
+structuredControl platform us txExpr txBlock g' =
    doTree returns dominatorTree emptyContext
  where
+   g :: CmmGraph
+   g = gwd_graph gwd
+
    gwd :: GraphWithDominators CmmNode
-   gwd = graphWithDominators g
+   gwd = initUs_ us $ asReducible $ graphWithDominators g'
 
    dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted
                                        -- with highest reverse-postorder number first



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7474b57830261a94903da61bb2df33022c11357...05d26a650b6e9e1169b42376fe54bb00850722f2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7474b57830261a94903da61bb2df33022c11357...05d26a650b6e9e1169b42376fe54bb00850722f2
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/20230411/2fb83f04/attachment-0001.html>