[Git][ghc/ghc][wip/andreask/rubbish-backport] Fix LitRubbish being applied to values.

[Andreas Klebinger (@AndreasK)]

Andreas Klebinger pushed to branch wip/andreask/rubbish-backport at Glasgow Haskell Compiler / GHC


Commits:
e6b824d8 by Andreas Klebinger at 2022-12-19T17:47:47+01:00
Fix LitRubbish being applied to values.

This fixes #19824

This is the 9.2 backport of commit 52ce8590ab18fb1fc99bd9aa24c016f786d7f7d1

- - - - -


1 changed file:

- compiler/GHC/CoreToStg.hs


Changes:

=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -43,8 +43,8 @@ import GHC.Builtin.Types ( unboxedUnitDataCon )
 import GHC.Types.Literal
 import GHC.Utils.Outputable
 import GHC.Utils.Monad
+import GHC.Utils.Misc (HasDebugCallStack)
 import GHC.Data.FastString
-import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Driver.Session
 import GHC.Platform.Ways
@@ -375,7 +375,7 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
 -- handle with the function coreToPreStgRhs.
 
 coreToStgExpr
-        :: CoreExpr
+        :: HasDebugCallStack => CoreExpr
         -> CtsM StgExpr
 
 -- The second and third components can be derived in a simple bottom up pass, not
@@ -389,17 +389,18 @@ coreToStgExpr
 coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"
 coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"
 coreToStgExpr (Lit l)                           = return (StgLit l)
-coreToStgExpr (App l@(Lit LitRubbish{}) Type{}) = coreToStgExpr l
 coreToStgExpr (Var v) = coreToStgApp v [] []
 coreToStgExpr (Coercion _)
   -- See Note [Coercion tokens]
   = coreToStgApp coercionTokenId [] []
 
 coreToStgExpr expr@(App _ _)
-  = coreToStgApp f args ticks
-  where
-    (f, args, ticks) = myCollectArgs expr
-
+  = case app_head of
+      Var f               -> coreToStgApp f args ticks -- Regular application
+      Lit l at LitRubbish{}  -> return (StgLit l) -- LitRubbish
+      _                   -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)
+    where
+      (app_head, args, ticks) = myCollectArgs expr
 coreToStgExpr expr@(Lam _ _)
   = let
         (args, body) = myCollectBinders expr
@@ -692,7 +693,7 @@ data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks
 
 -- Convert the RHS of a binding from Core to STG. This is a wrapper around
 -- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs
+coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
 coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr
 coreToPreStgRhs expr@(Lam _ _) =
     let
@@ -951,13 +952,13 @@ myCollectBinders expr
     go bs (Cast e _)         = go bs e
     go bs e                  = (reverse bs, e)
 
--- | Precondition: argument expression is an 'App', and there is a 'Var' at the
--- head of the 'App' chain.
-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish])
+-- | If the argument expression is (potential chain of) 'App', return the head
+-- of the app chain, and collect ticks/args along the chain.
+myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
 myCollectArgs expr
   = go expr [] []
   where
-    go (Var v)          as ts = (v, as, ts)
+    go h@(Var _v)       as ts = (h, as, ts)
     go (App f a)        as ts = go f (a:as) ts
     go (Tick t e)       as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as
                                        , ppr e $$ ppr as $$ ppr ts )
@@ -966,7 +967,7 @@ myCollectArgs expr
     go (Cast e _)       as ts = go e as ts
     go (Lam b e)        as ts
        | isTyVar b            = go e as ts -- Note [Collect args]
-    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+    go e                as ts = (e, as, ts)
 
 {- Note [Collect args]
 ~~~~~~~~~~~~~~~~~~~~~~



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

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