Improve rule-matching for let expressions

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

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 65835d9..b5ae45f 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -14,14 +14,13 @@ import CoreSyn
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprType, mkPiTypes )
 import CoreFVs                 ( exprsFreeVars )
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprType, mkPiTypes )
 import CoreFVs                 ( exprsFreeVars )

-import CoreSubst       ( Subst, mkSubst, substExpr )

 import CoreTidy                ( tidyRules )
 import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )
 import CoreTidy                ( tidyRules )
 import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )

-import DataCon         ( dataConRepArity, isVanillaDataCon, dataConTyVars )
-import Type            ( Type, tyConAppArgs, tyVarsOfTypes )
+import DataCon         ( dataConRepArity, dataConUnivTyVars )
+import Type            ( Type, tyConAppArgs )
+import Coercion                ( coercionKind )

 import Rules           ( matchN )
 import Rules           ( matchN )

-import Unify           ( coreRefineTys )

 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var             ( Var )
 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var             ( Var )

@@ -116,7 +115,7 @@ This happens if
 
 Hence the "OR" part of Note [Good arguments] below.
 
 
 Hence the "OR" part of Note [Good arguments] below.
 

-ALTERNATIVE: pass both boxed and unboxed versions.  This no longer saves
+ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves

 allocation, but does perhaps save evals. In the RULE we'd have
 something like
 
 allocation, but does perhaps save evals. In the RULE we'd have
 something like
 

@@ -126,6 +125,25 @@ If at the call site the (I# x) was an unfolding, then we'd have to
 rely on CSE to eliminate the duplicate allocation.... This alternative
 doesn't look attractive enough to pursue.
 
 rely on CSE to eliminate the duplicate allocation.... This alternative
 doesn't look attractive enough to pursue.
 

+ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that 
+the conservative reboxing story prevents many useful functions from being
+specialised.  Example:
+       foo :: Maybe Int -> Int -> Int
+       foo   (Just m) 0 = 0
+       foo x@(Just m) n = foo x (n-m)
+Here the use of 'x' will clearly not require boxing in the specialised function.
+
+The strictness analyser has the same problem, in fact.  Example:
+       f p@(a,b) = ...
+If we pass just 'a' and 'b' to the worker, it might need to rebox the
+pair to create (a,b).  A more sophisticated analysis might figure out
+precisely the cases in which this could happen, but the strictness
+analyser does no such analysis; it just passes 'a' and 'b', and hopes
+for the best.
+
+So my current choice is to make SpecConstr similarly aggressive, and
+ignore the bad potential of reboxing.
+

 
 Note [Good arguments]
 ~~~~~~~~~~~~~~~~~~~~~
 
 Note [Good arguments]
 ~~~~~~~~~~~~~~~~~~~~~

@@ -300,6 +318,24 @@ may avoid allocating it altogether.  Just like for constructors.
 
 Looks cool, but probably rare...but it might be easy to implement.
 
 
 Looks cool, but probably rare...but it might be easy to implement.
 

+
+Note [SpecConstr for casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider 
+    data family T a :: *
+    data instance T Int = T Int
+
+    foo n = ...
+       where
+         go (T 0) = 0
+         go (T n) = go (T (n-1))
+
+The recursive call ends up looking like 
+       go (T (I# ...) `cast` g)
+So we want to spot the construtor application inside the cast.
+That's why we have the Cast case in argToPat
+
+

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

@@ -429,12 +465,6 @@ data ConValue  = CV AltCon [CoreArg]
 instance Outputable ConValue where
    ppr (CV con args) = ppr con <+> interpp'SP args
 
 instance Outputable ConValue where
    ppr (CV con args) = ppr con <+> interpp'SP args
 

-refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
--- The substitution is a type substitution only
-refineConstrEnv subst env = mapVarEnv refine_con_value env
-  where
-    refine_con_value (CV con args) = CV con (map (substExpr subst) args)
-

 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 
 data HowBound = RecFun -- These are the recursive functions for which 
 emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
 
 data HowBound = RecFun -- These are the recursive functions for which 

@@ -455,7 +485,13 @@ instance Outputable HowBound where
 
 lookupScopeEnv env v = lookupVarEnv (scope env) v
 
 
 lookupScopeEnv env v = lookupVarEnv (scope env) v
 

-extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
+
+extendBndrsWith :: HowBound -> ScEnv -> [Var] -> ScEnv
+extendBndrsWith how_bound env bndrs 
+  =  env { scope = scope env `extendVarEnvList` 
+                       [(bndr,how_bound) | bndr <- bndrs] }
+
+extendBndrs env bndrs = extendBndrsWith Other env bndrs

 extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
 
     -- When we encounter
 extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }
 
     -- When we encounter

@@ -467,44 +503,25 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs
   = case con of
        DEFAULT    -> env1
        LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])
   = case con of
        DEFAULT    -> env1
        LitAlt lit -> extendCons env1 scrut case_bndr (CV con [])

-       DataAlt dc -> extend_data_con dc
+       DataAlt dc -> extendCons env1 scrut case_bndr (CV con vanilla_args)
+             where
+               vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
+                              varsToCoreExprs alt_bndrs

   where
   where

-    cur_scope = scope env
-    env1 = env { scope = extendVarEnvList cur_scope 
-                               [(b,how_bound) | b <- case_bndr:alt_bndrs] }
+    env1 = extendBndrsWith (get_how scrut) env (case_bndr:alt_bndrs)

 
        -- Record RecArg for the components iff the scrutinee is RecArg
 
        -- Record RecArg for the components iff the scrutinee is RecArg

+       -- I think the only reason for this is to keep the usage envt small
+       -- so is it worth it at all?

        --      [This comment looks plain wrong to me, so I'm ignoring it
        --           "Also forget if the scrutinee is a RecArg, because we're
        --           now in the branch of a case, and we don't want to
        --           record a non-scrutinee use of v if we have
        --              case v of { (a,b) -> ...(f v)... }" ]
        --      [This comment looks plain wrong to me, so I'm ignoring it
        --           "Also forget if the scrutinee is a RecArg, because we're
        --           now in the branch of a case, and we don't want to
        --           record a non-scrutinee use of v if we have
        --              case v of { (a,b) -> ...(f v)... }" ]

-    how_bound = case scrut of
-                 Var v -> lookupVarEnv cur_scope v `orElse` Other
-                 other -> Other
-
-    extend_data_con data_con
-       | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
-       | otherwise                 = extendCons env2 scrut case_bndr (CV con gadt_args)
-               -- Note env2 for GADTs
-       where
-    
-           vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
-                          map varToCoreExpr alt_bndrs
-
-           gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
-               -- This call generates some bogus warnings from substExpr,
-               -- because it's inconvenient to put all the Ids in scope
-               -- Will be fixed when we move to FC
-
-           (alt_tvs, _) = span isTyVar alt_bndrs
-           Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
-           subst = mkSubst in_scope tv_subst emptyVarEnv       -- No Id substitition
-           in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
-       
-           env2 | is_local  = env1
-                | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
-
+    get_how (Var v)    = lookupVarEnv (scope env) v `orElse` Other
+    get_how (Cast e _) = get_how e
+    get_how (Note _ e) = get_how e
+    get_how other      = Other

 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val
 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val

@@ -513,14 +530,6 @@ extendCons env scrut case_bndr val
        other -> env { cons = cons1 }
   where
     cons1 = extendVarEnv (cons env) case_bndr val
        other -> env { cons = cons1 }
   where
     cons1 = extendVarEnv (cons env) case_bndr val

-
-    -- When we encounter a recursive function binding
-    -- f = \x y -> ...
-    -- we want to extend the scope env with bindings 
-    -- that record that f is a RecFn and x,y are RecArgs
-extendRecBndr env fn bndrs
-  =  env { scope = scope env `extendVarEnvList` 
-                  ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }

 \end{code}
 
 
 \end{code}
 
 

@@ -533,7 +542,7 @@ extendRecBndr env fn bndrs
 \begin{code}
 data ScUsage
    = SCU {
 \begin{code}
 data ScUsage
    = SCU {

-       calls :: !(IdEnv ([Call])),     -- Calls
+       calls :: !(IdEnv [Call]),       -- Calls

                                        -- The functions are a subset of the 
                                        --      RecFuns in the ScEnv
 
                                        -- The functions are a subset of the 
                                        --      RecFuns in the ScEnv
 

@@ -572,9 +581,10 @@ data ArgOcc = NoOcc        -- Doesn't occur at all; or a type argument
 
 {-     Note  [ScrutOcc]
 
 
 {-     Note  [ScrutOcc]
 

-An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.
+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
+is *only* taken apart or applied.

 
 

-  Functions, litersl: ScrutOcc emptyUFM
+  Functions, literal: ScrutOcc emptyUFM

   Data constructors:  ScrutOcc subs,
 
 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
   Data constructors:  ScrutOcc subs,
 
 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,

@@ -588,14 +598,20 @@ 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") <> parens (ppr xs)
+  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 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
+-- in the overall result, even if it's also used in a boxed way
+-- This might be too agressive; see Note [Reboxing] Alternative 3

 combineOcc NoOcc        occ           = occ
 combineOcc occ                  NoOcc         = occ
 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
 combineOcc NoOcc        occ           = occ
 combineOcc occ                  NoOcc         = occ
 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)

+combineOcc occ           (ScrutOcc ys) = ScrutOcc ys
+combineOcc (ScrutOcc xs) occ          = ScrutOcc xs

 combineOcc UnkOcc        UnkOcc        = UnkOcc
 combineOcc _       _                  = BothOcc
 
 combineOcc UnkOcc        UnkOcc        = UnkOcc
 combineOcc _       _                  = BothOcc
 

@@ -608,10 +624,7 @@ conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
 
 conArgOccs (ScrutOcc fm) (DataAlt dc) 
   | Just pat_arg_occs <- lookupUFM fm dc
 
 conArgOccs (ScrutOcc fm) (DataAlt dc) 
   | Just pat_arg_occs <- lookupUFM fm dc

-  = tyvar_unks ++ pat_arg_occs
-  where
-    tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
-              | otherwise           = []
+  = [UnkOcc | tv <- dataConUnivTyVars dc] ++ pat_arg_occs

 
 conArgOccs other con = repeat UnkOcc
 \end{code}
 
 conArgOccs other con = repeat UnkOcc
 \end{code}

@@ -680,6 +693,7 @@ scExpr env e@(App _ _)
        ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
        ; let call_usg = case fn of
                           Var f | Just RecFun <- lookupScopeEnv env f
        ; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
        ; let call_usg = case fn of
                           Var f | Just RecFun <- lookupScopeEnv env f

+                                , not (null args)      -- Not a proper call!

                                 -> SCU { calls = unitVarEnv f [(cons env, args)], 
                                          occs  = emptyVarEnv }
                           other -> nullUsage
                                 -> SCU { calls = unitVarEnv f [(cons env, args)], 
                                          occs  = emptyVarEnv }
                           other -> nullUsage

@@ -691,43 +705,48 @@ scExpr env e@(App _ _)
 ----------------------
 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
 -- Used for the scrutinee of a case, 
 ----------------------
 scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
 -- Used for the scrutinee of a case, 

--- or the function of an application
-scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
-scScrut env e        occ = scExpr env e
+-- or the function of an application.
+-- Remember to look through casts
+scScrut env e@(Var v)   occ = returnUs (varUsage env v occ, e)
+scScrut env (Cast e co) occ = do { (usg, e') <- scScrut env e occ
+                                ; returnUs (usg, Cast e' co) }
+scScrut env e          occ = scExpr env e

 
 
 ----------------------
 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 
 
 ----------------------
 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)

-scBind env (Rec [(fn,rhs)])
-  | notNull val_bndrs
-  = scExpr env_fn_body body            `thenUs` \ (usg, body') ->
-    specialise env fn bndrs body' usg  `thenUs` \ (rules, spec_prs) ->
-       -- Note body': the specialised copies should be based on the 
-       --             optimised version of the body, in case there were
-       --             nested functions inside.
-    let
-       SCU { calls = calls, occs = occs } = usg
-    in
-    returnUs (extendBndr env fn,       -- For the body of the letrec, just
-                                       -- extend the env with Other to record 
-                                       -- that it's in scope; no funny RecFun business
-             SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
-             Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
-  where
-    (bndrs,body) = collectBinders rhs
-    val_bndrs    = filter isId bndrs
-    env_fn_body         = extendRecBndr env fn bndrs
-

 scBind env (Rec prs)
 scBind env (Rec prs)

-  = mapAndUnzipUs do_one prs   `thenUs` \ (usgs, prs') ->
-    returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
-  where
-    do_one (bndr,rhs) = scExpr env rhs `thenUs` \ (usg, rhs') ->
-                       returnUs (usg, (bndr,rhs'))
+  = do { let bndrs = map fst prs
+             rhs_env = extendBndrsWith RecFun env bndrs
+
+       ; (rhs_usgs, prs_w_occs) <- mapAndUnzipUs (scRecRhs rhs_env) prs
+       ; let rhs_usg   = combineUsages rhs_usgs
+             rhs_calls = calls rhs_usg
+
+       ; prs_s <- mapUs (specialise env rhs_calls) prs_w_occs
+       ; return (extendBndrs env bndrs, 
+                               -- For the body of the letrec, just
+                               -- extend the env with Other to record 
+                               -- that it's in scope; no funny RecFun business
+                   rhs_usg { calls = calls rhs_usg `delVarEnvList` bndrs },
+                   Rec (concat prs_s)) }

 
 scBind env (NonRec bndr rhs)
 
 scBind env (NonRec bndr rhs)

-  = scExpr env rhs     `thenUs` \ (usg, rhs') ->
-    returnUs (extendBndr env bndr, usg, NonRec bndr rhs')
+  = do { (usg, rhs') <- scExpr env rhs
+       ; return (extendBndr env bndr, usg, NonRec bndr rhs') }
+
+----------------------
+scRecRhs :: ScEnv -> (Id,CoreExpr)
+        -> UniqSM (ScUsage, (Id, CoreExpr, [ArgOcc]))
+-- The returned [ArgOcc] says how the visible,
+-- lambda-bound binders of the RHS are used
+-- (including the TyVar binders)
+scRecRhs env (bndr,rhs)
+  = do { let (arg_bndrs,body) = collectBinders rhs
+             body_env = extendBndrsWith RecArg env arg_bndrs
+       ; (body_usg, body') <- scExpr body_env body
+       ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs
+       ; return (rhs_usg, (bndr, mkLams arg_bndrs body', arg_occs)) }

 
 ----------------------
 varUsage env v use 
 
 ----------------------
 varUsage env v use 

@@ -744,33 +763,52 @@ varUsage env v use
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-specialise :: ScEnv
-          -> Id                        -- Functionn
-          -> [CoreBndr] -> CoreExpr    -- Its RHS
-          -> ScUsage                   -- Info on usage
-          -> UniqSM ([CoreRule],       -- Rules
-                     [(Id,CoreExpr)])  -- Bindings
-
-specialise env fn bndrs body body_usg
-  = do { let (_, bndr_occs) = lookupOccs body_usg bndrs
-
-       ; mb_calls <- mapM (callToPats (scope env) bndr_occs)
-                          (lookupVarEnv (calls body_usg) fn `orElse` [])
-
-       ; let good_calls :: [([Var], [CoreArg])]
-             good_calls = catMaybes mb_calls
+specialise 
+   :: ScEnv
+   -> IdEnv [Call]             -- Info on usage
+   -> (Id, CoreExpr, [ArgOcc]) -- Original binding, plus info on how the rhs's
+                               -- lambda-binders are used (includes TyVar bndrs)
+   -> UniqSM [(Id,CoreExpr)]   -- Original binding (decorated with rules)
+                               -- plus specialised bindings
+
+-- 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 calls (fn, rhs, arg_occs)
+  | notNull arg_occs,  -- Only specialise functions
+    Just all_calls <- lookupVarEnv calls fn
+  = do { mb_pats <- mapM (callToPats (scope env) arg_occs) all_calls
+
+       ; let good_pats :: [([Var], [CoreArg])]
+             good_pats = catMaybes mb_pats

              in_scope = mkInScopeSet $ unionVarSets $
              in_scope = mkInScopeSet $ unionVarSets $

-                        [ exprsFreeVars pats `delVarSetList` vs 
-                        | (vs,pats) <- good_calls ]
-             uniq_calls = nubBy (same_call in_scope) good_calls
-    in
-    mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
-                 (uniq_calls `zip` [1..]) }
+                        [ exprsFreeVars pats
+                        | (vs,pats) <- good_pats ]
+               -- This in-scope set is used when matching to see if
+               -- we have identical patterns.  We want to treat the
+               -- forall'd variables of each pattern as "in scope",
+               -- because each in turn serves as the match target for
+               -- a matchN call.  So don't remove the 'vs' from the free vars!
+             uniq_pats = nubBy (same_pat in_scope) good_pats
+--     ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
+--                                     text "calls" <+> ppr all_calls,
+--                                     text "good pats" <+> ppr good_pats,
+--                             text "uniq pats" <+> ppr uniq_pats])  $
+--       return ()
+
+       ; (rules, spec_prs) <- mapAndUnzipUs (spec_one fn rhs) 
+                                            (uniq_pats `zip` [1..])
+
+       ; return ((fn `addIdSpecialisations` rules, rhs) : spec_prs) }
+
+  | otherwise
+  = return [(fn,rhs)]  -- The boring case

   where
   where

-       -- Two calls are the same if they match both ways
-    same_call in_scope (vs1,as1)(vs2,as2)
-        =  isJust (matchN in_scope vs1 as1 as2)
-        && isJust (matchN in_scope vs2 as2 as1)
+       -- Two pats are the same if they match both ways
+    same_pat in_scope (vs1,as1)(vs2,as2)
+       =  isJust (matchN in_scope vs1 as1 as2)
+       && isJust (matchN in_scope vs2 as2 as1)

 
 callToPats :: InScopeEnv -> [ArgOcc] -> Call
           -> UniqSM (Maybe ([Var], [CoreExpr]))
 
 callToPats :: InScopeEnv -> [ArgOcc] -> Call
           -> UniqSM (Maybe ([Var], [CoreExpr]))

@@ -787,13 +825,13 @@ callToPats in_scope bndr_occs (con_env, args)
                -- Quantify over variables that are not in sccpe
                -- See Note [Shadowing] at the top
                
                -- Quantify over variables that are not in sccpe
                -- See Note [Shadowing] at the top
                

-       ; if or good_pats 
+       ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
+         if or good_pats 

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

-spec_one :: ScEnv
-        -> Id                                  -- Function
+spec_one :: Id                                 -- Function

         -> CoreExpr                            -- Rhs of the original function
         -> (([Var], [CoreArg]), Int)
         -> UniqSM (CoreRule, (Id,CoreExpr))    -- Rule and binding
         -> CoreExpr                            -- Rhs of the original function
         -> (([Var], [CoreArg]), Int)
         -> UniqSM (CoreRule, (Id,CoreExpr))    -- Rule and binding

@@ -819,7 +857,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 rhs ((vars_to_bind, pats), rule_number)
+spec_one fn rhs ((vars_to_bind, pats), rule_number)

   = getUniqueUs                `thenUs` \ spec_uniq ->
     let 
        fn_name      = idName fn
   = getUniqueUs                `thenUs` \ spec_uniq ->
     let 
        fn_name      = idName fn

@@ -892,17 +930,28 @@ argToPat :: InScopeEnv                    -- What's in scope at the fn defn site
 argToPat in_scope con_env arg@(Type ty) arg_occ
   = return (False, arg)
 
 argToPat in_scope con_env arg@(Type ty) arg_occ
   = return (False, arg)
 

-argToPat in_scope con_env (Var v) arg_occ
-  | not (isLocalId v) || v `elemVarEnv` in_scope
-  =    -- The recursive call passes a variable that 
-       -- is in scope at the function definition site
-       -- It's worth specialising on this if
-       --      (a) it's used in an interesting way in the body
-       --      (b) we know what its value is
-    if    (case arg_occ of { UnkOcc -> False; other -> True }) -- (a)
-       && isValueUnfolding (idUnfolding v)                     -- (b)
-    then return (True, Var v)
-    else wildCardPat (idType v)
+argToPat in_scope con_env (Note n arg) arg_occ
+  = argToPat in_scope con_env arg arg_occ
+       -- Note [Notes in call patterns]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
+       -- Perhaps we should not ignore profiling notes, but I'm going to
+       -- ride roughshod over them all for now.
+       --- See Note [Notes in RULE matching] in Rules
+
+argToPat in_scope con_env (Let _ arg) arg_occ
+  = argToPat in_scope con_env arg arg_occ
+       -- Look through let expressions
+       -- e.g.         f (let v = rhs in \y -> ...v...)
+       -- Here we can specialise for f (\y -> ...)
+       -- because the rule-matcher will look through the let.
+
+argToPat in_scope con_env (Cast arg co) arg_occ
+  = do { (interesting, arg') <- argToPat in_scope con_env arg arg_occ
+       ; if interesting then 
+               return (interesting, Cast arg' co)
+         else 
+               wildCardPat (snd (coercionKind co)) }

 
 argToPat in_scope con_env arg arg_occ
   | is_value_lam arg
 
 argToPat in_scope con_env arg arg_occ
   | is_value_lam arg

@@ -913,26 +962,46 @@ argToPat in_scope con_env arg arg_occ
        | otherwise = is_value_lam e
     is_value_lam other = False
 
        | otherwise = is_value_lam e
     is_value_lam other = False
 

+  -- Check for a constructor application
+  -- NB: this *precedes* the Var case, so that we catch nullary constrs

 argToPat in_scope con_env arg arg_occ
   | Just (CV dc args) <- is_con_app_maybe con_env arg
   , case arg_occ of
        ScrutOcc _ -> True              -- Used only by case scrutinee
 argToPat in_scope con_env arg arg_occ
   | Just (CV dc args) <- is_con_app_maybe con_env arg
   , case arg_occ of
        ScrutOcc _ -> True              -- Used only by case scrutinee

-       BothOcc    -> case arg of       -- Used by case scrut
-                       App {} -> True  -- ...and elsewhere...
+       BothOcc    -> case arg of       -- Used elsewhere
+                       App {} -> True  --     see Note [Reboxing]

                        other  -> False
        other      -> False     -- No point; the arg is not decomposed
   = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
        ; return (True, mk_con_app dc (map snd args')) }
 
                        other  -> False
        other      -> False     -- No point; the arg is not decomposed
   = do { args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
        ; return (True, mk_con_app dc (map snd args')) }
 

+  -- Check if the argument is a variable that 
+  -- is in scope at the function definition site
+  -- It's worth specialising on this if
+  --   (a) it's used in an interesting way in the body
+  --   (b) we know what its value is
+argToPat in_scope con_env (Var v) arg_occ
+  | not (isLocalId v) || v `elemVarEnv` in_scope,
+    case arg_occ of { UnkOcc -> False; other -> True },        -- (a)
+    isValueUnfolding (idUnfolding v)                   -- (b)
+  = return (True, Var v)
+
+{-     I'm really not sure what this comment means
+       And by not wild-carding we tend to get forall'd 
+       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!!

 argToPat in_scope con_env (Var v) arg_occ
 argToPat in_scope con_env (Var v) arg_occ

-  =    -- 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!!
-    return (False, Var v)
+  = return (False, Var v)
+-}

 
 

--- The default case: make a wild-card
-argToPat in_scope con_env arg arg_occ = wildCardPat (exprType arg)
+  -- The default case: make a wild-card
+argToPat in_scope con_env arg arg_occ
+  = wildCardPat (exprType arg)

 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs
 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs

@@ -951,35 +1020,33 @@ argsToPats in_scope con_env args
 
 \begin{code}
 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
 
 \begin{code}
 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue

+is_con_app_maybe env (Lit lit)
+  = Just (CV (LitAlt lit) [])
+
+is_con_app_maybe env expr      -- Maybe it's a constructor application
+  | (Var fun, args) <- collectArgs expr,
+    Just con <- isDataConWorkId_maybe fun,
+    args `lengthAtLeast` dataConRepArity con
+       -- Might be > because the arity excludes type args
+  = Just (CV (DataAlt con) args)
+

 is_con_app_maybe env (Var v)
 is_con_app_maybe env (Var v)

-  = case lookupVarEnv env v of
-       Just stuff -> Just stuff
-               -- You might think we could look in the idUnfolding here
+  | Just stuff <- lookupVarEnv env v
+  = Just stuff -- You might think we could look in the idUnfolding here

                -- but that doesn't take account of which branch of a 
                -- case we are in, which is the whole point
 
                -- but that doesn't take account of which branch of a 
                -- case we are in, which is the whole point
 

-       Nothing | isCheapUnfolding unf
-               -> is_con_app_maybe env (unfoldingTemplate unf)
-               where
-                 unf = idUnfolding v
-               -- However we do want to consult the unfolding 
-               -- as well, for let-bound constructors!
-
-       other  -> Nothing
-
-is_con_app_maybe env (Lit lit)
-  = Just (CV (LitAlt lit) [])
-
-is_con_app_maybe env expr
-  = case collectArgs expr of
-       (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
-                         args `lengthAtLeast` dataConRepArity con
-               -- Might be > because the arity excludes type args
-                       -> Just (CV (DataAlt con) args)
+  | isCheapUnfolding unf
+  = is_con_app_maybe env (unfoldingTemplate unf)
+  where
+    unf = idUnfolding v
+       -- However we do want to consult the unfolding 
+       -- as well, for let-bound constructors!

 
 

-       other -> Nothing
+is_con_app_maybe env expr = Nothing

 
 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 mk_con_app (LitAlt lit)  []   = Lit lit
 mk_con_app (DataAlt con) args = mkConApp con args
 
 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
 mk_con_app (LitAlt lit)  []   = Lit lit
 mk_con_app (DataAlt con) args = mkConApp con args

+mk_con_app other args = panic "SpecConstr.mk_con_app"

 \end{code}
 \end{code}