diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2021-05-11 18:09:24 +0200 |
---|---|---|
committer | Andreas Klebinger <klebinger.andreas@gmx.at> | 2021-05-17 15:54:06 +0200 |
commit | 52ce8590ab18fb1fc99bd9aa24c016f786d7f7d1 (patch) | |
tree | 16664bb24ce91ba93b80d96b16dce2a18372d1d1 | |
parent | e0ded198e9ec1c8bb7253506569e7ae47818e791 (diff) | |
download | haskell-52ce8590ab18fb1fc99bd9aa24c016f786d7f7d1.tar.gz |
Fix LitRubbish being applied to values.wip/andreask/rubbish_core2stg
This fixes #19824
-rw-r--r-- | compiler/GHC/CoreToStg.hs | 26 |
1 files changed, 14 insertions, 12 deletions
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 3754bd4d0f..a868fa2de3 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -41,6 +41,7 @@ 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.Panic import GHC.Utils.Panic.Plain @@ -373,7 +374,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 @@ -387,17 +388,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@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 @@ -689,7 +691,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 @@ -950,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 = assertPpr (not (tickishIsCode t) || all isTypeArg as) (ppr e $$ ppr as $$ ppr ts) $ @@ -965,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] ~~~~~~~~~~~~~~~~~~~~~~ |