[Git][ghc/ghc][master] Scrub some partiality in `GHC.Core.Opt.Simplify.Utils`.

[Marge Bot (@marge-bot)]

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


Commits:
b8304648 by M Farkas-Dyck at 2022-10-21T09:11:56-04:00
Scrub some partiality in `GHC.Core.Opt.Simplify.Utils`.

- - - - -


1 changed file:

- compiler/GHC/Core/Opt/Simplify/Utils.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -42,7 +42,7 @@ module GHC.Core.Opt.Simplify.Utils (
         isExitJoinId
     ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding (head, init, last, tail)
 
 import GHC.Core
 import GHC.Types.Literal ( isLitRubbish )
@@ -84,6 +84,7 @@ import GHC.Utils.Trace
 
 import Control.Monad    ( when )
 import Data.List        ( sortBy )
+import qualified Data.List as Partial ( head )
 
 {- *********************************************************************
 *                                                                      *
@@ -450,7 +451,7 @@ mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bn
 mkLazyArgStop :: OutType -> ArgInfo -> SimplCont
 mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd
   where
-    arg_sd = subDemandIfEvaluated (head (ai_dmds fun_info))
+    arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
 
 -------------------
 contIsRhs :: SimplCont -> Maybe RecFlag
@@ -592,7 +593,7 @@ contEvalContext k = case k of
     -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all.
     -- But for now we just panic:
   ApplyToVal{}               -> pprPanic "contEvalContext" (ppr k)
-  StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (head (ai_dmds fun_info))
+  StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
   StrictBind{sc_bndr=bndr}   -> subDemandIfEvaluated (idDemandInfo bndr)
   Select{}                   -> topSubDmd
     -- Perhaps reconstruct the demand on the scrutinee by looking at field
@@ -1665,7 +1666,7 @@ rebuildLam :: SimplEnv
 rebuildLam _env [] body _cont
   = return body
 
-rebuildLam env bndrs body cont
+rebuildLam env bndrs@(bndr:_) body cont
   = {-# SCC "rebuildLam" #-} try_eta bndrs body
   where
     rec_ids  = seRecIds env
@@ -1682,7 +1683,7 @@ rebuildLam env bndrs body cont
       | -- Try eta reduction
         seDoEtaReduction env
       , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd
-      = do { tick (EtaReduction (head bndrs))
+      = do { tick (EtaReduction bndr)
            ; return etad_lam }
 
       | -- Try eta expansion
@@ -1690,7 +1691,7 @@ rebuildLam env bndrs body cont
       , seEtaExpand env
       , any isRuntimeVar bndrs  -- Only when there is at least one value lambda already
       , Just body_arity <- exprEtaExpandArity (seArityOpts env) body
-      = do { tick (EtaExpansion (head bndrs))
+      = do { tick (EtaExpansion bndr)
            ; let body' = etaExpandAT in_scope body_arity body
            ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body
                                           , text "after" <+> ppr body'])
@@ -2391,12 +2392,12 @@ mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts
 --      2. Eliminate Identity Case
 --------------------------------------------------
 
-mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : _)      -- Identity case
+mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts')      -- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
        ; return (mkTicks ticks $ re_cast scrut rhs1) }
   where
-    ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts)
+    ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts'
     identity_alt (Alt con args rhs) = check_eq rhs con args
 
     check_eq (Cast rhs co) con args        -- See Note [RHS casts]



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

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