Handle type-lets better
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 17 May 2017 08:44:46 +0000 (09:44 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 17 May 2017 08:47:21 +0000 (09:47 +0100)
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.

compiler/basicTypes/Id.hs
compiler/basicTypes/Var.hs
compiler/coreSyn/CoreFVs.hs
compiler/simplCore/CSE.hs
compiler/simplCore/FloatIn.hs
testsuite/tests/simplCore/should_compile/T13708.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index 3934ae7..8a5e28a 100644 (file)
@@ -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)
index 2bdd5f0..d07d9ec 100644 (file)
@@ -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)
 
index 4dc1ed2..f5343ca 100644 (file)
@@ -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
index 95df5f8..83f5ee6 100644 (file)
@@ -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]
index e765455..02a7f74 100644 (file)
@@ -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 (file)
index 0000000..43f42bc
--- /dev/null
@@ -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
index 5ed520d..f4f22b9 100644 (file)
@@ -269,3 +269,4 @@ test('T12600',
      run_command,
      ['$MAKE -s --no-print-directory T12600'])
 test('T13658', normal, compile, ['-dcore-lint'])
+test('T13708', normal, compile, [''])