For a non-recursive let, make sure we extend the value environment

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 4c0d927..a2ef2a1 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -11,7 +11,10 @@
 -- for details
 
 module SpecConstr(
 -- for details
 
 module SpecConstr(

-       specConstrProgram, SpecConstrAnnotation(..)
+       specConstrProgram
+#ifdef GHCI
+        , SpecConstrAnnotation(..)
+#endif

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -24,18 +27,17 @@ import CoreFVs              ( exprsFreeVars )
 import CoreMonad
 import HscTypes         ( ModGuts(..) )
 import WwLib           ( mkWorkerArgs )
 import CoreMonad
 import HscTypes         ( ModGuts(..) )
 import WwLib           ( mkWorkerArgs )

-import DataCon         ( dataConTyCon, dataConRepArity, dataConUnivTyVars )
-import TyCon            ( TyCon )
-import Literal          ( literalType )
+import DataCon

 import Coercion        
 import Rules
 import Type            hiding( substTy )
 import Id
 import Coercion        
 import Rules
 import Type            hiding( substTy )
 import Id

-import MkId            ( mkImpossibleExpr )
+import MkCore          ( mkImpossibleExpr )

 import Var
 import VarEnv
 import VarSet
 import Name
 import Var
 import VarEnv
 import VarSet
 import Name

+import BasicTypes

 import DynFlags                ( DynFlags(..) )
 import StaticFlags     ( opt_PprStyle_Debug )
 import Maybes          ( orElse, catMaybes, isJust, isNothing )
 import DynFlags                ( DynFlags(..) )
 import StaticFlags     ( opt_PprStyle_Debug )
 import Maybes          ( orElse, catMaybes, isJust, isNothing )

@@ -50,7 +52,16 @@ import UniqFM
 import MonadUtils
 import Control.Monad   ( zipWithM )
 import Data.List
 import MonadUtils
 import Control.Monad   ( zipWithM )
 import Data.List

-import Data.Data        ( Data, Typeable )
+
+
+-- See Note [SpecConstrAnnotation]
+#ifndef GHCI
+type SpecConstrAnnotation = ()
+#else
+import Literal          ( literalType )
+import TyCon            ( TyCon )
+import GHC.Exts( SpecConstrAnnotation(..) )
+#endif

 \end{code}
 
 -----------------------------------------------------
 \end{code}
 
 -----------------------------------------------------

@@ -384,6 +395,17 @@ But fspec doesn't have decent strictnes info.  As it happened,
 and hence f.  But now f's strictness is less than its arity, which
 breaks an invariant.
 
 and hence f.  But now f's strictness is less than its arity, which
 breaks an invariant.
 

+Note [SpecConstrAnnotation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+SpecConstrAnnotation is defined in GHC.Exts, and is only guaranteed to
+be available in stage 2 (well, until the bootstrap compiler can be
+guaranteed to have it)
+
+So we define it to be () in stage1 (ie when GHCI is undefined), and
+'#ifdef' out the code that uses it.
+
+See also Note [Forcing specialisation]
+

 Note [Forcing specialisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With stream fusion and in other similar cases, we want to fully specialise
 Note [Forcing specialisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With stream fusion and in other similar cases, we want to fully specialise

@@ -493,20 +515,6 @@ unbox the strict fields, becuase T is polymorphic!)
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

-\subsection{Annotations}
-%*                                                                     *
-%************************************************************************
-
-Annotating a type with NoSpecConstr will make SpecConstr not specialise
-for arguments of that type.
-
-\begin{code}
-data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
-                deriving( Data, Typeable, Eq )
-\end{code}
-
-%************************************************************************
-%*                                                                     *

 \subsection{Top level wrapper stuff}
 %*                                                                     *
 %************************************************************************
 \subsection{Top level wrapper stuff}
 %*                                                                     *
 %************************************************************************

@@ -568,6 +576,7 @@ type HowBoundEnv = VarEnv HowBound  -- Domain is OutVars
 ---------------------
 type ValueEnv = IdEnv Value            -- Domain is OutIds
 data Value    = ConVal AltCon [CoreArg]        -- _Saturated_ constructors
 ---------------------
 type ValueEnv = IdEnv Value            -- Domain is OutIds
 data Value    = ConVal AltCon [CoreArg]        -- _Saturated_ constructors

+                                       --   The AltCon is never DEFAULT

              | LambdaVal               -- Inlinable lambdas or PAPs
 
 instance Outputable Value where
              | LambdaVal               -- Inlinable lambdas or PAPs
 
 instance Outputable Value where

@@ -671,7 +680,7 @@ extendCaseBndrs env case_bndr con alt_bndrs
        --      Var v  -> extendValEnv env1 v cval
        --      _other -> env1
  where
        --      Var v  -> extendValEnv env1 v cval
        --      _other -> env1
  where

-   zap v | isTyVar v = v               -- See NB2 above
+   zap v | isTyCoVar v = v             -- See NB2 above

          | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
          | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of

@@ -682,22 +691,41 @@ extendCaseBndrs env case_bndr con alt_bndrs
                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
                                       varsToCoreExprs alt_bndrs
 
                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
                                       varsToCoreExprs alt_bndrs
 

-ignoreTyCon :: ScEnv -> TyCon -> Bool
-ignoreTyCon env tycon
-  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr

 
 

-ignoreType :: ScEnv -> Type -> Bool
+decreaseSpecCount :: ScEnv -> Int -> ScEnv
+-- See Note [Avoiding exponential blowup]
+decreaseSpecCount env n_specs 
+  = env { sc_count = case sc_count env of
+                       Nothing -> Nothing
+                       Just n  -> Just (n `div` (n_specs + 1)) }
+       -- The "+1" takes account of the original function; 
+       -- See Note [Avoiding exponential blowup]
+
+---------------------------------------------------
+-- See Note [SpecConstrAnnotation]
+ignoreType    :: ScEnv -> Type   -> Bool
+ignoreAltCon  :: ScEnv -> AltCon -> Bool
+forceSpecBndr :: ScEnv -> Var    -> Bool
+#ifndef GHCI
+ignoreType    _ _ = False
+ignoreAltCon  _ _ = False
+forceSpecBndr _ _ = False
+
+#else /* GHCI */
+
+ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
+ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
+ignoreAltCon _   DEFAULT      = panic "ignoreAltCon"  -- DEFAULT cannot be in a ConVal
+

 ignoreType env ty
   = case splitTyConApp_maybe ty of
       Just (tycon, _) -> ignoreTyCon env tycon
       _               -> False
 
 ignoreType env ty
   = case splitTyConApp_maybe ty of
       Just (tycon, _) -> ignoreTyCon env tycon
       _               -> False
 

-ignoreAltCon :: ScEnv -> AltCon -> Bool
-ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
-ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
-ignoreAltCon _   DEFAULT      = True
+ignoreTyCon :: ScEnv -> TyCon -> Bool
+ignoreTyCon env tycon
+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr

 
 

-forceSpecBndr :: ScEnv -> Var -> Bool

 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
 
 forceSpecFunTy :: ScEnv -> Type -> Bool
 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
 
 forceSpecFunTy :: ScEnv -> Type -> Bool

@@ -714,15 +742,7 @@ forceSpecArgTy env ty
         || any (forceSpecArgTy env) tys
 
 forceSpecArgTy _ _ = False
         || any (forceSpecArgTy env) tys
 
 forceSpecArgTy _ _ = False

-
-decreaseSpecCount :: ScEnv -> Int -> ScEnv
--- See Note [Avoiding exponential blowup]
-decreaseSpecCount env n_specs 
-  = env { sc_count = case sc_count env of
-                       Nothing -> Nothing
-                       Just n  -> Just (n `div` (n_specs + 1)) }
-       -- The "+1" takes account of the original function; 
-       -- See Note [Avoiding exponential blowup]
+#endif /* GHCI */

 \end{code}
 
 Note [Avoiding exponential blowup]
 \end{code}
 
 Note [Avoiding exponential blowup]

@@ -935,16 +955,20 @@ scExpr' env (Case scrut b ty alts)
           ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
           ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)

-  | isTyVar bndr       -- Type-lets may be created by doBeta
+  | isTyCoVar bndr     -- Type-lets may be created by doBeta

   = scExpr' (extendScSubst env bndr rhs) body
 
   = scExpr' (extendScSubst env bndr rhs) body
 

-  | otherwise             -- Note [Local let bindings]
+  | otherwise  

   = do { let (body_env, bndr') = extendBndr env bndr
   = do { let (body_env, bndr') = extendBndr env bndr

-             body_env2 = extendHowBound body_env [bndr'] RecFun
-       ; (body_usg, body') <- scExpr body_env2 body
-

        ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
 
        ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
 

+       ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+                                  -- Note [Local let bindings]
+             RI _ rhs' _ _ _ = rhs_info
+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+       ; (body_usg, body') <- scExpr body_env3 body
+

           -- NB: We don't use the ForceSpecConstr mechanism (see
           -- Note [Forcing specialisation]) for non-recursive bindings
           -- at the moment. I'm not sure if this is the right thing to do.
           -- NB: We don't use the ForceSpecConstr mechanism (see
           -- Note [Forcing specialisation]) for non-recursive bindings
           -- at the moment. I'm not sure if this is the right thing to do.

@@ -1172,6 +1196,7 @@ specialise
 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs) 
                          spec_info@(SI specs spec_count mb_unspec)
   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs) 
                          spec_info@(SI specs spec_count mb_unspec)
   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]

+  , not (isNeverActive (idInlineActivation fn))        -- See Note [Transfer activation]

   , notNull arg_bndrs          -- Only specialise functions
   , Just all_calls <- lookupVarEnv bind_calls fn
   = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
   , notNull arg_bndrs          -- Only specialise functions
   , Just all_calls <- lookupVarEnv bind_calls fn
   = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls

@@ -1277,7 +1302,9 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
              body_ty    = exprType spec_body
              rule_rhs   = mkVarApps (Var spec_id) spec_call_args
               inline_act = idInlineActivation fn
              body_ty    = exprType spec_body
              rule_rhs   = mkVarApps (Var spec_id) spec_call_args
               inline_act = idInlineActivation fn

-             rule       = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
+             rule       = mkRule True {- Auto -} True {- Local -}
+                                  rule_name inline_act fn_name qvars pats rule_rhs
+                          -- See Note [Transfer activation]

        ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
 
 calcSpecStrictness :: Id                    -- The original function
        ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
 
 calcSpecStrictness :: Id                    -- The original function

@@ -1313,6 +1340,10 @@ specialised RHS, and that can lead directly to exponential behaviour.
 
 Note [Transfer activation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Transfer activation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~

+  This note is for SpecConstr, but exactly the same thing
+  happens in the overloading specialiser; see
+  Note [Auto-specialisation and RULES] in Specialise.
+

 In which phase should the specialise-constructor rules be active?
 Originally I made them always-active, but Manuel found that this
 defeated some clever user-written rules.  Then I made them active only
 In which phase should the specialise-constructor rules be active?
 Originally I made them always-active, but Manuel found that this
 defeated some clever user-written rules.  Then I made them active only

@@ -1323,8 +1354,9 @@ simplCore/should_compile/spec-inline.
 
 So now I just use the inline-activation of the parent Id, as the
 activation for the specialiation RULE, just like the main specialiser;
 
 So now I just use the inline-activation of the parent Id, as the
 activation for the specialiation RULE, just like the main specialiser;

-see Note [Auto-specialisation and RULES] in Specialise.

 
 

+This in turn means there is no point in specialising NOINLINE things,
+so we test for that.

 
 Note [Transfer strictness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Transfer strictness]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1390,7 +1422,7 @@ callToPats env bndr_occs (con_env, args)
                -- at the call site
                -- See Note [Shadowing] at the top
                
                -- at the call site
                -- See Note [Shadowing] at the top
                

-             (tvs, ids) = partition isTyVar qvars
+             (tvs, ids) = partition isTyCoVar qvars

              qvars'     = tvs ++ ids
                -- Put the type variables first; the type of a term
                -- variable may mention a type variable
              qvars'     = tvs ++ ids
                -- Put the type variables first; the type of a term
                -- variable may mention a type variable

@@ -1564,7 +1596,7 @@ isValue env (Var v)
        -- as well, for let-bound constructors!
 
 isValue env (Lam b e)
        -- as well, for let-bound constructors!
 
 isValue env (Lam b e)

-  | isTyVar b = case isValue env e of
+  | isTyCoVar b = case isValue env e of

                  Just _  -> Just LambdaVal
                  Nothing -> Nothing
   | otherwise = Just LambdaVal
                  Just _  -> Just LambdaVal
                  Nothing -> Nothing
   | otherwise = Just LambdaVal