Add (a) CoreM monad, (b) new Annotations feature

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 055f794..23127f4 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -20,24 +20,20 @@ import CoreSyn
 import CoreSubst
 import CoreUtils
 import CoreUnfold      ( couldBeSmallEnoughToInline )
-import CoreLint                ( showPass, endPass )
 import CoreFVs                 ( exprsFreeVars )
-import CoreTidy                ( tidyRules )
-import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )
 import DataCon         ( dataConRepArity, dataConUnivTyVars )
 import Coercion        
+import Rules
 import Type            hiding( substTy )
-import Id              ( Id, idName, idType, isDataConWorkId_maybe, idArity,
-                         mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
+import Id
 import Var
 import VarEnv
 import VarSet
 import Name
-import Rules           ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 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(..) )
 import Maybes          ( orElse, catMaybes, isJust, isNothing )
@@ -453,19 +449,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"
-                 (pprRules (tidyRules emptyTidyEnv (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
@@ -592,17 +577,28 @@ extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
 extendValEnv env _  Nothing   = env
 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
 
-extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
+extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
 -- When we encounter
 --     case scrut of b
 --         C x y -> ...
--- we want to bind b, and perhaps scrut too, to (C x y)
--- NB: Extends only the sc_vals part of the envt
-extendCaseBndrs env scrut case_bndr con alt_bndrs
-  = case scrut of
-       Var v  -> extendValEnv env1 v cval
-       _other -> env1
+-- we want to bind b, to (C x y)
+-- NB1: Extends only the sc_vals part of the envt
+-- NB2: Kill the dead-ness info on the pattern binders x,y, since
+--      they are potentially made alive by the [b -> C x y] binding
+extendCaseBndrs env case_bndr con alt_bndrs
+  | isDeadBinder case_bndr
+  = (env, alt_bndrs)
+  | otherwise
+  = (env1, map zap alt_bndrs)
+       -- NB: We used to bind v too, if scrut = (Var v); but
+        --     the simplifer has already done this so it seems
+        --     redundant to do so here
+       -- case scrut of
+       --      Var v  -> extendValEnv env1 v cval
+       --      _other -> env1
  where
+   zap v | isTyVar v = v               -- See NB2 above
+         | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
                DEFAULT    -> Nothing
@@ -789,15 +785,15 @@ scExpr' env (Case scrut b ty alts)
          ; return (alt_usg `combineUsage` scrut_usg',
                    Case scrut' b' (scSubstTy env ty) alts') }
 
-    sc_alt env scrut' b' (con,bs,rhs)
-      = do { let (env1, bs') = extendBndrsWith RecArg env bs
-                env2        = extendCaseBndrs env1 scrut' b' con bs'
+    sc_alt env _scrut' b' (con,bs,rhs)
+      = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
+                (env2, bs2) = extendCaseBndrs env1 b' con bs1
           ; (usg,rhs') <- scExpr env2 rhs
-          ; let (usg', arg_occs) = lookupOccs usg bs'
+          ; let (usg', arg_occs) = lookupOccs usg bs2
                 scrut_occ = case con of
                                DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
                                _          -> ScrutOcc emptyUFM
-          ; return (usg', scrut_occ, (con,bs',rhs')) }
+          ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
   | isTyVar bndr       -- Type-lets may be created by doBeta
@@ -1023,10 +1019,14 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
        ; let spec_count' = length pats + spec_count
        ; case sc_count env of
            Just max | spec_count' > max
-               -> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):" 
-                        (vcat [ptext (sLit "Function:") <+> ppr fn,
-                               ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
-                        return (nullUsage, spec_info)
+               -> WARN( True, msg ) return (nullUsage, spec_info)
+               where
+                  msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
+                                   , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
+                             , ptext (sLit "Use -fspec-constr-count=n to set the bound")
+                             , extra ]
+                  extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
+                        | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
 
            _normal_case -> do {