Fix it

5 files changed, 25 insertions, 11 deletions

diff --git a/compiler/GHC/Core/Op/Simplify.hs b/compiler/GHC/Core/Op/Simplify.hs
index 5c04ea7736..6f89de4b98 100644
--- a/compiler/GHC/Core/Op/Simplify.hs
+++ b/compiler/GHC/Core/Op/Simplify.hs
@@ -15,6 +15,7 @@ import GhcPrelude
 
 import GHC.Platform
 import GHC.Driver.Session
+import GHC.Core.Arity       ( etaExpand )
 import GHC.Core.Op.Simplify.Monad
 import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )
 import GHC.Core.Op.Simplify.Env
@@ -1799,16 +1800,15 @@ completeCall env var cont
   --     keepAlive# @arg_rep @arg_ty @out_rep @out_ty x (\s -> K[rhs]) s0
   | var `hasKey` keepAliveIdKey
   , ApplyToTy arg_rep hole1 cont1      <- -- cont
-    pprTrace "completeCall(wht)" (ppr var $$ ppr cont) cont
-  , ApplyToTy arg_ty   hole2 cont2     <- cont1
-  , ApplyToTy _res_rep _ cont3         <- cont2
-  , ApplyToTy _res_ty  _ cont4         <- cont3
-  , ApplyToVal dup5 x      env5 cont5 <- cont4
-  , ApplyToVal dup6 f      env6 cont6 <- cont5
-  , ApplyToVal dup7 s0     env7 cont7 <- cont6
+    pprTrace "completeCall(keepAlive#)" (ppr var $$ ppr cont) cont
+  , ApplyToTy arg_ty   hole2 cont2 <- cont1
+  , ApplyToTy _res_rep _     cont3 <- cont2
+  , ApplyToTy _res_ty  _     cont4 <- cont3
+  , ApplyToVal dup5 x  env5  cont5 <- cont4
+  , ApplyToVal dup6 f  env6  cont6 <- cont5
+  , ApplyToVal dup7 s0 env7  cont7 <- cont6
   , not $ contIsStop cont7
-    -- TODO: Eta expand?
-  , Lam f_arg f_rhs                   <- f
+  , Lam f_arg f_rhs                   <- etaExpand 1 f
   = do { let out_ty = contResultType cont
              out_rep = getRuntimeRep out_ty
        ; (floats1, f') <- rebuild env6 f_rhs cont7
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 4e136af5c0..b45d23f522 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -762,6 +762,11 @@ data ArgInfo = CpeApp  CoreArg
              | CpeCast Coercion
              | CpeTick (Tickish Id)
 
+instance Outputable ArgInfo where
+  ppr (CpeApp arg) = text "app" <+> ppr arg
+  ppr (CpeCast co) = text "cast" <+> ppr co
+  ppr (CpeTick tick) = text "tick" <+> ppr tick
+
 {-
  Note [runRW arg]
 ~~~~~~~~~~~~~~~~~~~
@@ -873,6 +878,10 @@ cpeApp top_env expr
                    rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Var s2, Var y]
              ; cpeBody env expr
              }
+    cpe_app _env (Var f) args _
+        | f `hasKey` keepAliveIdKey
+        = pprPanic "cpe_app(keepAlive#)" (ppr args)
+
     cpe_app env (Var v) args depth
       = do { v1 <- fiddleCCall v
            ; let e2 = lookupCorePrepEnv env v1
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index e62113390c..a50c57ac75 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -531,6 +531,7 @@ hasNoBinding id = case Var.idDetails id of
                         PrimOpId _       -> False   -- See Note [Primop wrappers] in PrimOp.hs
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
+                        NoBindingId      -> True
                         _                -> isCompulsoryUnfolding (idUnfolding id)
                                             -- See Note [Levity-polymorphic Ids]
 
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index af1ebb18cd..ac8176fa5b 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -168,6 +168,9 @@ data IdDetails
   | JoinId JoinArity           -- ^ An 'Id' for a join point taking n arguments
        -- Note [Join points] in GHC.Core
 
+  | NoBindingId  -- TODO: Revisit this
+       -- Note [Magic IDs]
+
 -- | Recursive Selector Parent
 data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq
   -- Either `TyCon` or `PatSyn` depending
@@ -214,6 +217,7 @@ pprIdDetails other     = brackets (pp other)
                                            ppWhen is_naughty (text "(naughty)")
    pp CoVarId                 = text "CoVarId"
    pp (JoinId arity)          = text "JoinId" <> parens (int arity)
+   pp NoBindingId             = text "NoBindingId"
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index b545cdc44e..56739b1c91 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -76,7 +76,7 @@ import GHC.Driver.Session
 import Outputable
 import FastString
 import ListSetOps
-import GHC.Types.Var (VarBndr(Bndr))
+import GHC.Types.Var (VarBndr(Bndr), setIdDetails)
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.Maybe       ( maybeToList )
@@ -1386,7 +1386,7 @@ seqId = pcMiscPrelId seqName ty info
 ------------------------------------------------
 keepAliveId :: Id
 keepAliveId
-  = pcMiscPrelId keepAliveName ty id_info
+  = pcMiscPrelId keepAliveName ty id_info `setIdDetails` NoBindingId
   where
     -- keepAlive#
     --   :: forall (rep_a :: RuntimeRep) (a :: TYPE rep_a)