[Git][ghc/ghc][master] Scrub some partiality in `GHC.Cmm.Info.Build`: `doSRTs` takes a `[(CAFSet,...

[Marge Bot (@marge-bot)]

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


Commits:
703a4665 by M Farkas-Dyck at 2022-12-20T21:14:46-05:00
Scrub some partiality in `GHC.Cmm.Info.Build`: `doSRTs` takes a `[(CAFSet, CmmDecl)]` but truly wants a `[(CAFSet, CmmStatics)]`.

- - - - -


4 changed files:

- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Utils/Outputable.hs


Changes:

=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -7,11 +7,14 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE EmptyCase #-}
 
 module GHC.Cmm (
      -- * Cmm top-level datatypes
      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
      CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+     CmmDataDecl, cmmDataDeclCmmDecl,
      CmmGraph, GenCmmGraph(..),
      toBlockMap, revPostorder, toBlockList,
      CmmBlock, RawCmmDecl,
@@ -52,6 +55,7 @@ import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 import GHC.Utils.Outputable
 
+import Data.Void (Void)
 import Data.List (intersperse)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -116,6 +120,14 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
 
 type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph
 type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
+type CmmDataDecl = GenCmmDataDecl CmmStatics
+type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded
+
+cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g
+cmmDataDeclCmmDecl = \ case
+    CmmProc void _ _ _ -> case void of
+    CmmData section d -> CmmData section d
+{-# INLINE cmmDataDeclCmmDecl #-}
 
 type RawCmmDecl
    = GenCmmDecl


=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -1,6 +1,6 @@
 {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
     GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
-    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
+    ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -884,7 +884,7 @@ doSRTs
   :: CmmConfig
   -> ModuleSRTInfo
   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks
-  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's
+  -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's
   -> IO (ModuleSRTInfo, [CmmDeclSRTs])
 
 doSRTs cfg moduleSRTInfo procs data_ = do
@@ -900,8 +900,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
         flip map data_ $
         \(set, decl) ->
           case decl of
-            CmmProc{} ->
-              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
+            CmmProc void _ _ _ -> case void of
             CmmData _ static ->
               case static of
                 CmmStatics lbl _ _ _ _ -> (lbl, set)
@@ -909,7 +908,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
 
       (proc_envs, procss) = unzip procs
       cafEnv = mapUnions proc_envs
-      decls = map snd data_ ++ concat procss
+      decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss
       staticFuns = mapFromList (getStaticFuns decls)
 
       platform = cmmPlatform cfg
@@ -980,8 +979,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
                       | otherwise ->
                           -- Not an IdLabel, ignore
                           srtMap
-                    CmmProc{} ->
-                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
+                    CmmProc void _ _ _ -> case void of)
                (moduleSRTMap moduleSRTInfo') data_
 
   return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')


=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -67,8 +67,8 @@ cmmPipeline logger cmm_config srtInfo prog = do
 --     [SRTs].
 --
 --   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing
-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))
+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
+cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics))
 cpsTop logger platform cfg proc =
     do
       ----------- Control-flow optimisations ----------------------------------


=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -151,6 +152,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NEL
 import Data.Time
 import Data.Time.Format.ISO8601
+import Data.Void
 
 import GHC.Fingerprint
 import GHC.Show         ( showMultiLineString )
@@ -1173,6 +1175,8 @@ instance OutputableP env SDoc where
 instance (OutputableP env a) => OutputableP env (Set a) where
     pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s))))
 
+instance OutputableP env Void where
+    pdoc _ = \ case
 
 {-
 ************************************************************************



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/703a466511307c5737d371898f9771991a0a31cc
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/20221220/6fbe797e/attachment-0001.html>