Remove unused imports

[ghc-hetmet.git] / compiler / specialise / SpecConstr.lhs

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 0280255..5357a53 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -20,7 +20,6 @@ import CoreSyn
 import CoreSubst
 import CoreUtils
 import CoreUnfold      ( couldBeSmallEnoughToInline )
-import CoreLint                ( showPass, endPass )
 import CoreFVs                 ( exprsFreeVars )
 import WwLib           ( mkWorkerArgs )
 import DataCon         ( dataConRepArity, dataConUnivTyVars )
@@ -28,13 +27,12 @@ import Coercion
 import Rules
 import Type            hiding( substTy )
 import Id
+import MkId            ( mkImpossibleExpr )
 import Var
 import VarEnv
 import VarSet
 import Name
-import OccName         ( mkSpecOcc )
-import ErrUtils                ( dumpIfSet_dyn )
-import DynFlags                ( DynFlags(..), DynFlag(..) )
+import DynFlags                ( DynFlags(..) )
 import StaticFlags     ( opt_PprStyle_Debug )
 import StaticFlags     ( opt_SpecInlineJoinPoints )
 import BasicTypes      ( Activation(..) )
@@ -367,6 +365,19 @@ specialising the loops arising from stream fusion, for example in NDP where
 we were getting literally hundreds of (mostly unused) specialisations of
 a local function.
 
+Note [Do not specialise diverging functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Specialising a function that just diverges is a waste of code.
+Furthermore, it broke GHC (simpl014) thus:
+   {-# STR Sb #-}
+   f = \x. case x of (a,b) -> f x
+If we specialise f we get
+   f = \x. case x of (a,b) -> fspec a b
+But fspec doesn't have decent strictnes info.  As it happened,
+(f x) :: IO t, so the state hack applied and we eta expanded fspec,
+and hence f.  But now f's strictness is less than its arity, which
+breaks an invariant.
+
 -----------------------------------------------------
                Stuff not yet handled
 -----------------------------------------------------
@@ -451,19 +462,8 @@ unbox the strict fields, becuase T is polymorphic!)
 %************************************************************************
 
 \begin{code}
-specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specConstrProgram dflags us binds
-  = do
-       showPass dflags "SpecConstr"
-
-       let (binds', _) = initUs us (go (initScEnv dflags) binds)
-
-       endPass dflags "SpecConstr" Opt_D_dump_spec binds'
-
-       dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-                     (pprRulesForUser (rulesOfBinds binds'))
-
-       return binds'
+specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]
+specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds)
   where
     go _   []          = return []
     go env (bind:binds) = do (env', bind') <- scTopBind env bind
@@ -778,7 +778,8 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut'         -- Known constructor; simplify
        = do { let (_, bs, rhs) = findAlt con alts
-                  alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+                                 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+                  alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
             ; scExpr alt_env' rhs }
                                
     sc_vanilla scrut_usg scrut'        -- Normal case
@@ -1019,8 +1020,9 @@ specialise
 
 specialise env bind_calls (fn, arg_bndrs, body, arg_occs) 
                          spec_info@(SI specs spec_count mb_unspec)
-  | notNull arg_bndrs, -- Only specialise functions
-    Just all_calls <- lookupVarEnv bind_calls fn
+  | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
+  , notNull arg_bndrs          -- Only specialise functions
+  , Just all_calls <- lookupVarEnv bind_calls fn
   = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
 --     ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
 --                                     text "calls" <+> ppr all_calls,