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 d9903ee..23127f4 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -20,33 +20,31 @@ import CoreSyn
 import CoreSubst
 import CoreUtils
 import CoreUnfold      ( couldBeSmallEnoughToInline )
 import CoreSubst
 import CoreUtils
 import CoreUnfold      ( couldBeSmallEnoughToInline )

-import CoreLint                ( showPass, endPass )

 import CoreFVs                 ( exprsFreeVars )
 import CoreFVs                 ( exprsFreeVars )

-import CoreTidy                ( tidyRules )
-import PprCore         ( pprRules )

 import WwLib           ( mkWorkerArgs )
 import DataCon         ( dataConRepArity, dataConUnivTyVars )
 import Coercion        
 import WwLib           ( mkWorkerArgs )
 import DataCon         ( dataConRepArity, dataConUnivTyVars )
 import Coercion        

+import Rules

 import Type            hiding( substTy )
 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 Var
 import VarEnv
 import VarSet
 import Name

-import Rules           ( addIdSpecialisations, mkLocalRule, rulesOfBinds )

 import OccName         ( mkSpecOcc )
 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 StaticFlags     ( opt_SpecInlineJoinPoints )
 import BasicTypes      ( Activation(..) )

-import Maybes          ( orElse, catMaybes, isJust )
+import Maybes          ( orElse, catMaybes, isJust, isNothing )

 import Util
 import List            ( nubBy, partition )
 import UniqSupply
 import Outputable
 import FastString
 import UniqFM
 import Util
 import List            ( nubBy, partition )
 import UniqSupply
 import Outputable
 import FastString
 import UniqFM

+import MonadUtils
+import Control.Monad   ( zipWithM )

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

@@ -343,6 +341,29 @@ The recursive call ends up looking like
 So we want to spot the construtor application inside the cast.
 That's why we have the Cast case in argToPat
 
 So we want to spot the construtor application inside the cast.
 That's why we have the Cast case in argToPat
 

+Note [Local recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a *local* recursive group, we can see all the calls to the
+function, so we seed the specialisation loop from the calls in the
+body, not from the calls in the RHS.  Consider:
+
+  bar m n = foo n (n,n) (n,n) (n,n) (n,n)
+   where
+     foo n p q r s
+       | n == 0    = m
+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
+
+If we start with the RHSs of 'foo', we get lots and lots of specialisations,
+most of which are not needed.  But if we start with the (single) call
+in the rhs of 'bar' we get exactly one fully-specialised copy, and all
+the recursive calls go to this fully-specialised copy. Indeed, the original
+function is later collected as dead code.  This is very important in 
+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.

 
 -----------------------------------------------------
                Stuff not yet handled
 
 -----------------------------------------------------
                Stuff not yet handled

@@ -428,22 +449,11 @@ unbox the strict fields, becuase T is polymorphic!)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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 []
   where
     go _   []          = return []

-    go env (bind:binds) = do (env', _, bind') <- scBind env bind
+    go env (bind:binds) = do (env', bind') <- scTopBind env bind

                              binds' <- go env' binds
                              return (bind' : binds')
 \end{code}
                              binds' <- go env' binds
                              return (bind' : binds')
 \end{code}

@@ -456,7 +466,8 @@ specConstrProgram dflags us binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-data ScEnv = SCE { sc_size :: Maybe Int,       -- Size threshold
+data ScEnv = SCE { sc_size  :: Maybe Int,      -- Size threshold
+                  sc_count :: Maybe Int,       -- Max # of specialisations for any one fn

 
                   sc_subst :: Subst,           -- Current substitution
                                                -- Maps InIds to OutExprs
 
                   sc_subst :: Subst,           -- Current substitution
                                                -- Maps InIds to OutExprs

@@ -472,9 +483,9 @@ data ScEnv = SCE { sc_size :: Maybe Int,    -- Size threshold
 
 ---------------------
 -- As we go, we apply a substitution (sc_subst) to the current term
 
 ---------------------
 -- As we go, we apply a substitution (sc_subst) to the current term

-type InExpr = CoreExpr         -- *Before* applying the subst
+type InExpr = CoreExpr         -- _Before_ applying the subst

 
 

-type OutExpr = CoreExpr                -- *After* applying the subst
+type OutExpr = CoreExpr                -- _After_ applying the subst

 type OutId   = Id
 type OutVar  = Var
 
 type OutId   = Id
 type OutVar  = Var
 

@@ -483,17 +494,18 @@ type HowBoundEnv = VarEnv HowBound        -- Domain is OutVars
 
 ---------------------
 type ValueEnv = IdEnv Value            -- Domain is OutIds
 
 ---------------------
 type ValueEnv = IdEnv Value            -- Domain is OutIds

-data Value    = ConVal AltCon [CoreArg]        -- *Saturated* constructors
+data Value    = ConVal AltCon [CoreArg]        -- _Saturated_ constructors

              | LambdaVal               -- Inlinable lambdas or PAPs
 
 instance Outputable Value where
    ppr (ConVal con args) = ppr con <+> interpp'SP args
              | LambdaVal               -- Inlinable lambdas or PAPs
 
 instance Outputable Value where
    ppr (ConVal con args) = ppr con <+> interpp'SP args

-   ppr LambdaVal        = ptext SLIT("<Lambda>")
+   ppr LambdaVal        = ptext (sLit "<Lambda>")

 
 ---------------------
 initScEnv :: DynFlags -> ScEnv
 initScEnv dflags
   = SCE { sc_size = specConstrThreshold dflags,
 
 ---------------------
 initScEnv :: DynFlags -> ScEnv
 initScEnv dflags
   = SCE { sc_size = specConstrThreshold dflags,

+         sc_count = specConstrCount dflags,

          sc_subst = emptySubst, 
          sc_how_bound = emptyVarEnv, 
          sc_vals = emptyVarEnv }
          sc_subst = emptySubst, 
          sc_how_bound = emptyVarEnv, 
          sc_vals = emptyVarEnv }

@@ -565,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 }
 
 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 -> ...
 -- 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
  where

+   zap v | isTyVar v = v               -- See NB2 above
+         | otherwise = zapIdOccInfo v

    env1 = extendValEnv env case_bndr cval
    cval = case con of
                DEFAULT    -> Nothing
    env1 = extendValEnv env case_bndr cval
    cval = case con of
                DEFAULT    -> Nothing

@@ -658,10 +681,10 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 -}
 
 instance Outputable ArgOcc where
 -}
 
 instance Outputable ArgOcc where

-  ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
-  ppr UnkOcc       = ptext SLIT("unk-occ")
-  ppr BothOcc      = ptext SLIT("both-occ")
-  ppr NoOcc                = ptext SLIT("no-occ")
+  ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
+  ppr UnkOcc       = ptext (sLit "unk-occ")
+  ppr BothOcc      = ptext (sLit "both-occ")
+  ppr NoOcc                = ptext (sLit "no-occ")

 
 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 -- that if the thing is scrutinised anywhere then we get to see that
 
 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 -- that if the thing is scrutinised anywhere then we get to see that

@@ -680,7 +703,7 @@ combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 
 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 
 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage

--- *Overwrite* the occurrence info for the scrutinee, if the scrutinee 
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee

 -- is a variable, and an interesting variable
 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
 -- is a variable, and an interesting variable
 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ

@@ -762,15 +785,15 @@ scExpr' env (Case scrut b ty alts)
          ; return (alt_usg `combineUsage` scrut_usg',
                    Case scrut' b' (scSubstTy env 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
           ; (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)
                 scrut_occ = case con of
                                DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)

-                               _ofther    -> ScrutOcc emptyUFM
-          ; return (usg', scrut_occ, (con,bs',rhs')) }
+                               _          -> ScrutOcc emptyUFM
+          ; return (usg', scrut_occ, (con, bs2, rhs')) }

 
 scExpr' env (Let (NonRec bndr rhs) body)
   | isTyVar bndr       -- Type-lets may be created by doBeta
 
 scExpr' env (Let (NonRec bndr rhs) body)
   | isTyVar bndr       -- Type-lets may be created by doBeta

@@ -804,15 +827,28 @@ scExpr' env (Let (NonRec bndr rhs) body)
 
                ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } 
                          `combineUsage` rhs_usg `combineUsage` spec_usg,
 
                ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } 
                          `combineUsage` rhs_usg `combineUsage` spec_usg,

-                         mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
+                         mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')

        }
 -}
 
        }
 -}
 

+-- A *local* recursive group: see Note [Local recursive groups]

 scExpr' env (Let (Rec prs) body)
 scExpr' env (Let (Rec prs) body)

-  = do { (env', bind_usg, bind') <- scBind env (Rec prs)
-       ; (body_usg, body') <- scExpr env' body
-       ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
+  = do { let (bndrs,rhss) = unzip prs
+             (rhs_env1,bndrs') = extendRecBndrs env bndrs
+             rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
+
+       ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+       ; (body_usg, body')     <- scExpr rhs_env2 body

 
 

+       -- NB: start specLoop from body_usg
+       ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
+                                       [SI [] 0 (Just usg) | usg <- rhs_usgs]
+
+       ; let all_usg = spec_usg `combineUsage` body_usg
+             bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
+
+       ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+                 Let bind' body') }

 
 -----------------------------------
 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
 
 -----------------------------------
 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)

@@ -856,14 +892,14 @@ scApp env (other_fn, args)
        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
 
 ----------------------
        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
 
 ----------------------

-scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
-scBind env (Rec prs)
+scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
+scTopBind env (Rec prs)

   | Just threshold <- sc_size env
   , not (all (couldBeSmallEnoughToInline threshold) rhss)
                -- No specialisation
   = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
   | Just threshold <- sc_size env
   , not (all (couldBeSmallEnoughToInline threshold) rhss)
                -- No specialisation
   = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs

-       ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
-       ; return (rhs_env, combineUsages rhs_usgs, Rec (bndrs' `zip` rhss')) }
+       ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
+       ; return (rhs_env, Rec (bndrs' `zip` rhss')) }

   | otherwise  -- Do specialisation
   = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
              rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
   | otherwise  -- Do specialisation
   = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
              rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun

@@ -871,38 +907,19 @@ scBind env (Rec prs)
        ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
        ; let rhs_usg = combineUsages rhs_usgs
 
        ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
        ; let rhs_usg = combineUsages rhs_usgs
 

-       ; (spec_usg, specs) <- spec_loop rhs_env2 (scu_calls rhs_usg)
-                                        (repeat [] `zip` rhs_infos)
-
-       ; let all_usg = rhs_usg `combineUsage` spec_usg
+       ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
+                                [SI [] 0 Nothing | _ <- bndrs]

 
        ; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
 
        ; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business

-                 all_usg { scu_calls = scu_calls rhs_usg `delVarEnvList` bndrs' },
-                 Rec (concat (zipWith addRules rhs_infos specs))) }
+                 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }

   where
     (bndrs,rhss) = unzip prs
 
   where
     (bndrs,rhss) = unzip prs
 

-    spec_loop :: ScEnv
-             -> CallEnv
-             -> [([CallPat], RhsInfo)]                 -- One per binder
-             -> UniqSM (ScUsage, [[SpecInfo]])         -- One list per binder
-    spec_loop env all_calls rhs_stuff
-       = do { (spec_usg_s, new_pats_s, specs) <- mapAndUnzip3M (specialise env all_calls) rhs_stuff
-            ; let spec_usg = combineUsages spec_usg_s
-            ; if all null new_pats_s then
-               return (spec_usg, specs) else do
-            { (spec_usg1, specs1) <- spec_loop env (scu_calls spec_usg) 
-                                               (zipWith add_pats new_pats_s rhs_stuff)
-            ; return (spec_usg `combineUsage` spec_usg1, zipWith (++) specs specs1) } }
-
-    add_pats :: [CallPat] -> ([CallPat], RhsInfo) -> ([CallPat], RhsInfo)
-    add_pats new_pats (done_pats, rhs_info) = (done_pats ++ new_pats, rhs_info)
-
-scBind env (NonRec bndr rhs)
-  = do { (usg, rhs') <- scExpr env rhs
+scTopBind env (NonRec bndr rhs)
+  = do { (_, rhs') <- scExpr env rhs

        ; let (env1, bndr') = extendBndr env bndr
              env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
        ; let (env1, bndr') = extendBndr env bndr
              env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')

-       ; return (env2, usg, NonRec bndr' rhs') }
+       ; return (env2, NonRec bndr' rhs') }

 
 ----------------------
 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
 
 ----------------------
 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)

@@ -919,12 +936,12 @@ scRecRhs env (bndr,rhs)
                -- Two pats are the same if they match both ways
 
 ----------------------
                -- Two pats are the same if they match both ways
 
 ----------------------

-addRules :: RhsInfo -> [SpecInfo] -> [(Id,CoreExpr)]
-addRules (fn, args, body, _) specs
-  = [(id,rhs) | (_,id,rhs) <- specs] ++ 
+specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
+specInfoBinds (fn, args, body, _) (SI specs _ _)
+  = [(id,rhs) | OS _ _ id rhs <- specs] ++ 

     [(fn `addIdSpecialisations` rules, mkLams args body)]
   where
     [(fn `addIdSpecialisations` rules, mkLams args body)]
   where

-    rules = [r | (r,_,_) <- specs]
+    rules = [r | OS _ r _ _ <- specs]

 
 ----------------------
 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
 
 ----------------------
 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage

@@ -947,35 +964,84 @@ type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
        -- Original binding f = \xs.body
        -- Plus info about usage of arguments
 
        -- Original binding f = \xs.body
        -- Plus info about usage of arguments
 

-type SpecInfo = (CoreRule, OutId, OutExpr)
-       -- One specialisation: Rule plus definition
+data SpecInfo = SI [OneSpec]           -- The specialisations we have generated
+                  Int                  -- Length of specs; used for numbering them
+                  (Maybe ScUsage)      -- Nothing => we have generated specialisations
+                                       --            from calls in the *original* RHS
+                                       -- Just cs => we haven't, and this is the usage
+                                       --            of the original RHS

 
 

+       -- One specialisation: Rule plus definition
+data OneSpec  = OS CallPat             -- Call pattern that generated this specialisation
+                  CoreRule             -- Rule connecting original id with the specialisation
+                  OutId OutExpr        -- Spec id + its rhs
+
+
+specLoop :: ScEnv
+        -> CallEnv
+        -> [RhsInfo]
+        -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
+        -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
+specLoop env all_calls rhs_infos usg_so_far specs_so_far
+  = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
+       ; let (new_usg_s, all_specs) = unzip specs_w_usg
+             new_usg   = combineUsages new_usg_s
+             new_calls = scu_calls new_usg
+             all_usg   = usg_so_far `combineUsage` new_usg
+       ; if isEmptyVarEnv new_calls then
+               return (all_usg, all_specs) 
+         else 
+               specLoop env new_calls rhs_infos all_usg all_specs }

 
 specialise 
    :: ScEnv
    -> CallEnv                          -- Info on calls
 
 specialise 
    :: ScEnv
    -> CallEnv                          -- Info on calls

-   -> ([CallPat], RhsInfo)             -- Original RHS plus patterns dealt with
-   -> UniqSM (ScUsage, [CallPat], [SpecInfo])  -- Specialised calls
+   -> RhsInfo
+   -> SpecInfo                         -- Original RHS plus patterns dealt with
+   -> UniqSM (ScUsage, SpecInfo)       -- New specialised versions and their usage

 
 -- Note: the rhs here is the optimised version of the original rhs
 -- So when we make a specialised copy of the RHS, we're starting
 -- from an RHS whose nested functions have been optimised already.
 
 
 -- Note: the rhs here is the optimised version of the original rhs
 -- So when we make a specialised copy of the RHS, we're starting
 -- from an RHS whose nested functions have been optimised already.
 

-specialise env bind_calls (done_pats, (fn, arg_bndrs, body, arg_occs))
+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
   | notNull arg_bndrs, -- Only specialise functions
     Just all_calls <- lookupVarEnv bind_calls fn

-  = do { pats <- callsToPats env done_pats arg_occs all_calls
+  = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls

 --     ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
 --                                     text "calls" <+> ppr all_calls,
 --                                     text "good pats" <+> ppr pats])  $
 --       return ()
 
 --     ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
 --                                     text "calls" <+> ppr all_calls,
 --                                     text "good pats" <+> ppr pats])  $
 --       return ()
 

-       ; (spec_usgs, specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
-                                             (pats `zip` [length done_pats..])
-
-       ; return (combineUsages spec_usgs, pats, specs) }
+               -- Bale out if too many specialisations
+               -- Rather a hacky way to do so, but it'll do for now
+       ; let spec_count' = length pats + spec_count
+       ; case sc_count env of
+           Just max | spec_count' > max
+               -> 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 {
+
+         (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
+                                                (pats `zip` [spec_count..])
+
+       ; let spec_usg = combineUsages spec_usgs
+             (new_usg, mb_unspec')
+                 = case mb_unspec of
+                     Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
+                     _                          -> (spec_usg,                      mb_unspec)
+           
+       ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }

   | otherwise
   | otherwise

-  = return (nullUsage, [], [])         -- The boring case
+  = return (nullUsage, spec_info)              -- The boring case

 
 
 ---------------------
 
 
 ---------------------

@@ -983,8 +1049,8 @@ spec_one :: ScEnv
         -> OutId       -- Function
         -> [Var]       -- Lambda-binders of RHS; should match patterns
         -> CoreExpr    -- Body of the original function
         -> OutId       -- Function
         -> [Var]       -- Lambda-binders of RHS; should match patterns
         -> CoreExpr    -- Body of the original function

-        -> (([Var], [CoreArg]), Int)
-        -> UniqSM (ScUsage, SpecInfo)  -- Rule and binding
+        -> (CallPat, Int)
+        -> UniqSM (ScUsage, OneSpec)   -- Rule and binding

 
 -- spec_one creates a specialised copy of the function, together
 -- with a rule for using it.  I'm very proud of how short this
 
 -- spec_one creates a specialised copy of the function, together
 -- with a rule for using it.  I'm very proud of how short this

@@ -1008,7 +1074,7 @@ spec_one :: ScEnv
            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 -}
 
            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 -}
 

-spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
+spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)

   = do {       -- Specialise the body
          let spec_env = extendScSubstList (extendScInScope env qvars)
                                           (arg_bndrs `zip` pats)
   = do {       -- Specialise the body
          let spec_env = extendScSubstList (extendScInScope env qvars)
                                           (arg_bndrs `zip` pats)

@@ -1033,7 +1099,7 @@ spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
              body_ty   = exprType spec_body
              rule_rhs  = mkVarApps (Var spec_id) spec_call_args
              rule      = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
              body_ty   = exprType spec_body
              rule_rhs  = mkVarApps (Var spec_id) spec_call_args
              rule      = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs

-       ; return (spec_usg, (rule, spec_id, spec_rhs)) }
+       ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }

 
 -- In which phase should the specialise-constructor rules be active?
 -- Originally I made them always-active, but Manuel found that
 
 -- In which phase should the specialise-constructor rules be active?
 -- Originally I made them always-active, but Manuel found that

@@ -1061,17 +1127,20 @@ they are constructor applications.
 type CallPat = ([Var], [CoreExpr])     -- Quantified variables and arguments
 
 
 type CallPat = ([Var], [CoreExpr])     -- Quantified variables and arguments
 
 

-callsToPats :: ScEnv -> [CallPat] -> [ArgOcc] -> [Call] -> UniqSM [CallPat]
+callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])

        -- Result has no duplicate patterns, 
        -- nor ones mentioned in done_pats
        -- Result has no duplicate patterns, 
        -- nor ones mentioned in done_pats

-callsToPats env done_pats bndr_occs calls
+       -- Bool indicates that there was at least one boring pattern
+callsToPats env done_specs bndr_occs calls

   = do { mb_pats <- mapM (callToPats env bndr_occs) calls
 
        ; let good_pats :: [([Var], [CoreArg])]
              good_pats = catMaybes mb_pats
   = do { mb_pats <- mapM (callToPats env bndr_occs) calls
 
        ; let good_pats :: [([Var], [CoreArg])]
              good_pats = catMaybes mb_pats

+             done_pats = [p | OS p _ _ _ <- done_specs] 

              is_done p = any (samePat p) done_pats
 
              is_done p = any (samePat p) done_pats
 

-       ; return (filterOut is_done (nubBy samePat good_pats)) }
+       ; return (any isNothing mb_pats, 
+                 filterOut is_done (nubBy samePat good_pats)) }

 
 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
        -- The [Var] is the variables to quantify over in the rule
 
 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
        -- The [Var] is the variables to quantify over in the rule

@@ -1084,7 +1153,7 @@ callToPats env bndr_occs (con_env, args)
   | otherwise
   = do { let in_scope = substInScope (sc_subst env)
        ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
   | otherwise
   = do { let in_scope = substInScope (sc_subst env)
        ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)

-       ; let (good_pats, pats) = unzip prs
+       ; let (interesting_s, pats) = unzip prs

              pat_fvs = varSetElems (exprsFreeVars pats)
              qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
                -- Quantify over variables that are not in sccpe
              pat_fvs = varSetElems (exprsFreeVars pats)
              qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
                -- Quantify over variables that are not in sccpe

@@ -1097,7 +1166,7 @@ callToPats env bndr_occs (con_env, args)
                -- variable may mention a type variable
 
        ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
                -- variable may mention a type variable
 
        ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $

-         if or good_pats 
+         if or interesting_s

          then return (Just (qvars', pats))
          else return Nothing }
 
          then return (Just (qvars', pats))
          else return Nothing }
 

@@ -1149,7 +1218,7 @@ argToPat in_scope val_env (Cast arg co) arg_occ
          else do
        { -- Make a wild-card pattern for the coercion
          uniq <- getUniqueUs
          else do
        { -- Make a wild-card pattern for the coercion
          uniq <- getUniqueUs

-       ; let co_name = mkSysTvName uniq FSLIT("sg")
+       ; let co_name = mkSysTvName uniq (fsLit "sg")

              co_var = mkCoVar co_name (mkCoKind ty1 ty2)
        ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
 
              co_var = mkCoVar co_name (mkCoKind ty1 ty2)
        ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
 

@@ -1200,12 +1269,18 @@ argToPat in_scope val_env (Var v) arg_occ
 --     variables that are in soope, which in turn can
 --     expose the weakness in let-matching
 --     See Note [Matching lets] in Rules
 --     variables that are in soope, which in turn can
 --     expose the weakness in let-matching
 --     See Note [Matching lets] in Rules

+

   -- Check for a variable bound inside the function. 
   -- Don't make a wild-card, because we may usefully share
   --   e.g.  f a = let x = ... in f (x,x)
   -- NB: this case follows the lambda and con-app cases!!
   -- Check for a variable bound inside the function. 
   -- Don't make a wild-card, because we may usefully share
   --   e.g.  f a = let x = ... in f (x,x)
   -- NB: this case follows the lambda and con-app cases!!

-argToPat _in_scope _val_env (Var v) _arg_occ
-  = return (False, Var v)
+-- argToPat _in_scope _val_env (Var v) _arg_occ
+--   = return (False, Var v)
+       -- SLPJ : disabling this to avoid proliferation of versions
+       -- also works badly when thinking about seeding the loop
+       -- from the body of the let
+       --       f x y = letrec g z = ... in g (x,y)
+       -- We don't want to specialise for that *particular* x,y

 
   -- The default case: make a wild-card
 argToPat _in_scope _val_env arg _arg_occ
 
   -- The default case: make a wild-card
 argToPat _in_scope _val_env arg _arg_occ

@@ -1213,7 +1288,7 @@ argToPat _in_scope _val_env arg _arg_occ
 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs
 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs

-                   ; let id = mkSysLocal FSLIT("sc") uniq ty
+                   ; let id = mkSysLocal (fsLit "sc") uniq ty

                    ; return (False, Var id) }
 
 argsToPats :: InScopeSet -> ValueEnv
                    ; return (False, Var id) }
 
 argsToPats :: InScopeSet -> ValueEnv

@@ -1245,7 +1320,9 @@ 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 = isValue env e
+  | isTyVar b = case isValue env e of
+                 Just _  -> Just LambdaVal
+                 Nothing -> Nothing

   | otherwise = Just LambdaVal
 
 isValue _env expr      -- Maybe it's a constructor application
   | otherwise = Just LambdaVal
 
 isValue _env expr      -- Maybe it's a constructor application