Handle type-lets better

Core allows non-recursive type-lets, thus

   let a = TYPE ty in ...

They are substituted away very quickly, but it's convenient for
some passes to produce them (rather than to have to substitute
immediately).

Trac #13708 tried the effect of not running the simplifer at all
(a rather bizarre thing to do, but still).  That showed that some
passes crashed because they always treated a let-bounder binder
as an Id.  This patch adds some easy fixes.

7 files changed, 39 insertions, 28 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 3934ae7dce..8a5e28a235 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -628,8 +628,10 @@ idFunRepArity :: Id -> RepArity
 idFunRepArity x = countFunRepArgs (idArity x) (idType x)
 
 -- | Returns true if an application to n args would diverge
-isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingSig (idStrictness id)
+isBottomingId :: Var -> Bool
+isBottomingId v
+  | isId v    = isBottomingSig (idStrictness v)
+  | otherwise = False
 
 idStrictness :: Id -> StrictSig
 idStrictness id = strictnessInfo (idInfo id)
diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index 2bdd5f0539..d07d9ec010 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -5,7 +5,7 @@
 \section{@Vars@: Variables}
 -}
 
-{-# LANGUAGE CPP, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}
 
 -- |
 -- #name_types#
@@ -521,7 +521,7 @@ instance Binary ArgFlag where
 ************************************************************************
 -}
 
-idInfo :: Id -> IdInfo
+idInfo :: HasDebugCallStack => Id -> IdInfo
 idInfo (Id { id_info = info }) = info
 idInfo other                   = pprPanic "idInfo" (ppr other)
 
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index 4dc1ed2f4a..f5343caf2b 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -31,7 +31,7 @@ module CoreFVs (
         varTypeTyCoVars,
         varTypeTyCoFVs,
         idUnfoldingVars, idFreeVars, dIdFreeVars,
-        idRuleAndUnfoldingVars, idRuleAndUnfoldingVarsDSet,
+        bndrRuleAndUnfoldingVarsDSet,
         idFVs,
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
         ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
@@ -626,22 +626,15 @@ idFVs :: Id -> FV
 -- Type variables, rule variables, and inline variables
 idFVs id = ASSERT( isId id)
            varTypeTyCoFVs id `unionFV`
-           idRuleAndUnfoldingFVs id
+           bndrRuleAndUnfoldingFVs id
 
-bndrRuleAndUnfoldingFVs :: Var -> FV
-bndrRuleAndUnfoldingFVs v | isTyVar v = emptyFV
-                          | otherwise = idRuleAndUnfoldingFVs v
-
-idRuleAndUnfoldingVars :: Id -> VarSet
-idRuleAndUnfoldingVars id = fvVarSet $ idRuleAndUnfoldingFVs id
-
-idRuleAndUnfoldingVarsDSet :: Id -> DVarSet
-idRuleAndUnfoldingVarsDSet id = fvDVarSet $ idRuleAndUnfoldingFVs id
-
-idRuleAndUnfoldingFVs :: Id -> FV
-idRuleAndUnfoldingFVs id = ASSERT( isId id)
-                           idRuleFVs id `unionFV` idUnfoldingFVs id
+bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
+bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id
 
+bndrRuleAndUnfoldingFVs :: Id -> FV
+bndrRuleAndUnfoldingFVs id
+  | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id
+  | otherwise = emptyFV
 
 idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
 idRuleVars id = fvVarSet $ idRuleFVs id
@@ -690,7 +683,7 @@ freeVarsBind :: CoreBind
 freeVarsBind (NonRec binder rhs) body_fvs
   = ( AnnNonRec binder rhs2
     , freeVarsOf rhs2 `unionFVs` body_fvs2
-                      `unionFVs` fvDVarSet (bndrRuleAndUnfoldingFVs binder) )
+                      `unionFVs` bndrRuleAndUnfoldingVarsDSet binder )
     where
       rhs2      = freeVars rhs
       body_fvs2 = binder `delBinderFV` body_fvs
@@ -702,7 +695,7 @@ freeVarsBind (Rec binds) body_fvs
     (binders, rhss) = unzip binds
     rhss2        = map freeVars rhss
     rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
-    binders_fvs  = fvDVarSet $ mapUnionFV idRuleAndUnfoldingFVs binders
+    binders_fvs  = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders
     all_fvs      = rhs_body_fvs `unionFVs` binders_fvs
             -- The "delBinderFV" happens after adding the idSpecVars,
             -- since the latter may add some of the binders as fvs
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 95df5f8b09..83f5ee6a3b 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -352,15 +352,19 @@ cse_bind toplevel env (in_id, in_rhs) out_id
     (env', out_id') = addBinding env in_id out_id out_rhs
 
 addBinding :: CSEnv                      -- Includes InId->OutId cloning
-           -> InId
+           -> InVar                      -- Could be a let-bound type
            -> OutId -> OutExpr           -- Processed binding
            -> (CSEnv, OutId)             -- Final env, final bndr
 -- Extend the CSE env with a mapping [rhs -> out-id]
 -- unless we can instead just substitute [in-id -> rhs]
+--
+-- It's possible for the binder to be a type variable (see
+-- Note [Type-let] in CoreSyn), in which case we can just substitute.
 addBinding env in_id out_id rhs'
-  | noCSE in_id = (env,                              out_id)
-  | use_subst   = (extendCSSubst env in_id rhs',     out_id)
-  | otherwise   = (extendCSEnv env rhs' id_expr', zapped_id)
+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)
+  | noCSE in_id      = (env,                              out_id)
+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)
+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)
   where
     id_expr'  = varToCoreExpr out_id
     zapped_id = zapIdUsageInfo out_id
@@ -381,7 +385,7 @@ addBinding env in_id out_id rhs'
                    _      -> False
 
 noCSE :: InId -> Bool
-noCSE id = not (isAlwaysActive (idInlineActivation id))
+noCSE id =  not (isAlwaysActive (idInlineActivation id))
              -- See Note [CSE for INLINE and NOINLINE]
          || isAnyInlinePragma (idInlinePragma id)
              -- See Note [CSE for stable unfoldings]
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
index e765455dfc..02a7f741c5 100644
--- a/compiler/simplCore/FloatIn.hs
+++ b/compiler/simplCore/FloatIn.hs
@@ -485,7 +485,7 @@ fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
   where
     body_fvs2 = body_fvs `delDVarSet` id
 
-    rule_fvs = idRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]
+    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]
     extra_fvs | noFloatIntoRhs NonRecursive id rhs
               = rule_fvs `unionDVarSet` rhs_fvs
               | otherwise
@@ -515,7 +515,7 @@ fiBind dflags to_drop (AnnRec bindings) body_fvs
     rhss_fvs = map freeVarsOf rhss
 
         -- See Note [extra_fvs (1,2)]
-    rule_fvs = mapUnionDVarSet idRuleAndUnfoldingVarsDSet ids
+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
     extra_fvs = rule_fvs `unionDVarSet`
                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
                               , noFloatIntoRhs Recursive bndr rhs ]
diff --git a/testsuite/tests/simplCore/should_compile/T13708.hs b/testsuite/tests/simplCore/should_compile/T13708.hs
new file mode 100644
index 0000000000..43f42bc4d0
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13708.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -O -fmax-simplifier-iterations=0 #-}
+
+-- Not running the simplifier leads to type-lets persisting longer
+
+module T13708 where
+
+indexOr :: a -> Int -> [a] -> a
+indexOr fallback idx xs =
+  if (idx < length xs)
+  then xs !! idx
+  else fallback
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 5ed520d597..f4f22b9dc5 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -269,3 +269,4 @@ test('T12600',
      run_command,
      ['$MAKE -s --no-print-directory T12600'])
 test('T13658', normal, compile, ['-dcore-lint'])
+test('T13708', normal, compile, [''])