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

scApp env (Var fn, args)	-- Function is a variable
  = ASSERT( not (null args) )
    do	{ args_w_usgs <- mapM (scExpr env) args
	; let (arg_usgs, args') = unzip args_w_usgs
	      arg_usg = combineUsages arg_usgs
	; case scSubstId env fn of
	    fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
			-- Do beta-reduction and try again

	    Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
		where
		  fn_usg = case lookupHowBound env fn' of
				Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')], 
					             scu_occs  = emptyVarEnv }
				Just RecArg -> SCU { scu_calls = emptyVarEnv,
					             scu_occs  = unitVarEnv fn' (ScrutOcc emptyUFM) }
				Nothing     -> nullUsage


	    other_fn' -> return (arg_usg, mkApps other_fn' args') }
		-- NB: doing this ignores any usage info from the substituted
		--     function, but I don't think that matters.  If it does
		--     we can fix it.
  where
    doBeta :: OutExpr -> [OutExpr] -> OutExpr
    -- ToDo: adjust for System IF
    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
    doBeta fn	           args	        = mkApps fn args

-- The function is almost always a variable, but not always.  
-- In particular, if this pass follows float-in,
-- which it may, we can get 
--	(let f = ...f... in f) arg1 arg2
scApp env (other_fn, args)
  = do 	{ (fn_usg,   fn')   <- scExpr env other_fn
	; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
	; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }

----------------------
scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBind env (Rec prs)
  | Just threshold <- sc_size env
  , not force_spec
  , not (all (couldBeSmallEnoughToInline threshold) rhss)
		-- No specialisation
  = do	{ let (rhs_env,bndrs') = extendRecBndrs env bndrs
	; (_, 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

	; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
	; let rhs_usg = combineUsages rhs_usgs

	; (_, specs) <- specLoop rhs_env2 force_spec
                                 (scu_calls rhs_usg) rhs_infos nullUsage
				 [SI [] 0 Nothing | _ <- bndrs]

	; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
		  Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
  where
    (bndrs,rhss) = unzip prs
    force_spec = any (forceSpecBndr env) bndrs
      -- Note [Forcing specialisation]

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')
	; return (env2, NonRec bndr' rhs') }

----------------------
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
scRecRhs env (bndr,rhs)
  = do	{ let (arg_bndrs,body) = collectBinders rhs
	      (body_env, arg_bndrs') = 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, RI bndr (mkLams arg_bndrs' body')
                                   arg_bndrs body arg_occs) }
		-- The arg_occs says how the visible,
		-- lambda-bound binders of the RHS are used
		-- (including the TyVar binders)
	 	-- Two pats are the same if they match both ways

----------------------
specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
  = [(id,rhs) | OS _ _ id rhs <- specs] ++ 
    [(fn `addIdSpecialisations` rules, new_rhs)]
  where
    rules = [r | OS _ r _ _ <- specs]

----------------------
varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
varUsage env v use 
  | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv 
					      , scu_occs = unitVarEnv v use }
  | otherwise		   	        = nullUsage

data RhsInfo = RI OutId 		-- The binder
                  OutExpr		-- The new RHS
		  [InVar] InExpr	-- The *original* RHS (\xs.body)
					--   Note [Specialise original body]
                  [ArgOcc]		-- Info on how the xs occur in body

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
					-- See Note [Local recursive groups]

	-- 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
         -> Bool                                -- force specialisation?
                                                -- Note [Forcing specialisation]
	 -> CallEnv
	 -> [RhsInfo]
	 -> ScUsage -> [SpecInfo]		-- One per binder; acccumulating parameter
	 -> UniqSM (ScUsage, [SpecInfo])	-- ...ditto...
specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
  = do	{ specs_w_usg <- zipWithM (specialise env force_spec 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 force_spec new_calls rhs_infos all_usg all_specs }

specialise 
   :: ScEnv
   -> Bool                              -- force specialisation?
                                        --   Note [Forcing specialisation]
   -> CallEnv				-- Info on 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.

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
--	; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
--                                      , text "arg_occs" <+> ppr arg_occs
--	  			      ,	text "calls" <+> ppr all_calls
--	  			      , text "good pats" <+> ppr pats])  $
--	  return ()

		-- Bale out if too many specialisations
	; let n_pats      = length pats
              spec_count' = n_pats + spec_count
	; case sc_count env of
	    Just max | not force_spec && spec_count' > max
		-> pprTrace "SpecConstr" msg $  
                   return (nullUsage, spec_info)
		where
		   msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
		       	            , nest 2 (ptext (sLit "has") <+> 
                                              speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
                                              ptext (sLit "but the limit is") <+> 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 {

          let spec_env = decreaseSpecCount env n_pats
	; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
					         (pats `zip` [spec_count..])
		-- See Note [Specialise original body]

	; 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
  = return (nullUsage, spec_info)		-- The boring case


---------------------
spec_one :: ScEnv
	 -> OutId	-- Function
	 -> [InVar]	-- Lambda-binders of RHS; should match patterns
	 -> InExpr	-- Body of the original function
	 -> (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
-- function is, considering what it does :-).

{- 
  Example
  
     In-scope: a, x::a   
     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
	  [c::*, v::(b,c) are presumably bound by the (...) part]
  ==>
     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
		  (...entire body of f...) [b -> (b,c), 
  					    y -> ((:) (a,(b,c)) (x,v) hw)]
  
     RULE:  forall b::* c::*,		-- Note, *not* forall a, x
		   v::(b,c),
		   hw::[(a,(b,c))] .
  
	    f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
-}

spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
  = do	{ spec_uniq <- getUniqueUs
        ; let spec_env = extendScSubstList (extendScInScope env qvars)
				           (arg_bndrs `zip` pats)
	      fn_name    = idName fn
	      fn_loc     = nameSrcSpan fn_name
	      spec_occ   = mkSpecOcc (nameOccName fn_name)
	      rule_name  = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
	      spec_name  = mkInternalName spec_uniq spec_occ fn_loc
--	; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ 
--	  return ()

	-- Specialise the body
	; (spec_usg, spec_body) <- scExpr spec_env body

--	; pprTrace "done spec_one}" (ppr fn) $ 
--	  return ()

		-- And build the results
	; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) 
	      		     `setIdStrictness` spec_str    	-- See Note [Transfer strictness]
			     `setIdArity` count isId spec_lam_args
	      spec_str   = calcSpecStrictness fn spec_lam_args pats
	      (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
	      	-- Usual w/w hack to avoid generating 
	      	-- a spec_rhs of unlifted type and no args

              spec_rhs   = mkLams spec_lam_args spec_body
	      body_ty    = exprType spec_body
	      rule_rhs   = mkVarApps (Var spec_id) spec_call_args
              inline_act = idInlineActivation fn
	      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
                   -> [Var] -> [CoreExpr]    -- Call pattern
		   -> StrictSig              -- Strictness of specialised thing
-- See Note [Transfer strictness]
calcSpecStrictness fn qvars pats
  = StrictSig (mkTopDmdType spec_dmds TopRes)
  where
    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
    StrictSig (DmdType _ dmds _) = idStrictness fn

    dmd_env = go emptyVarEnv dmds pats

    go env ds (Type {} : pats) = go env ds pats
    go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
    go env _      _            = env

    go_one env d   (Var v) = extendVarEnv_C both env v d
    go_one env (Box d)   e = go_one env d e
    go_one env (Eval (Prod ds)) e 
    	   | (Var _, args) <- collectArgs e = go env ds args
    go_one env _         _ = env

type CallPat = ([Var], [CoreExpr])	-- Quantified variables and arguments


callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
	-- Result has no duplicate patterns, 
	-- nor ones mentioned in done_pats
	-- 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
	      done_pats = [p | OS p _ _ _ <- done_specs] 
	      is_done p = any (samePat p) done_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
	--	Type variables come first, since they may scope 
	--	over the following term variables
	-- The [CoreExpr] are the argument patterns for the rule
callToPats env bndr_occs (con_env, args)
  | length args < length bndr_occs	-- Check saturated
  = return Nothing
  | otherwise
  = do	{ let in_scope = substInScope (sc_subst env)
	; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
	; 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
		-- at the call site
		-- See Note [Shadowing] at the top
		
	      (tvs, ids) = partition isTyCoVar qvars
	      qvars'     = tvs ++ ids
		-- Put the type variables first; the type of a term
		-- variable may mention a type variable

	; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
	  if or interesting_s
	  then return (Just (qvars', pats))
	  else return Nothing }

    -- argToPat takes an actual argument, and returns an abstracted
    -- version, consisting of just the "constructor skeleton" of the
    -- argument, with non-constructor sub-expression replaced by new
    -- placeholder variables.  For example:
    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)

argToPat :: ScEnv
         -> InScopeSet			-- What's in scope at the fn defn site
	 -> ValueEnv			-- ValueEnv at the call site
	 -> CoreArg			-- A call arg (or component thereof)
	 -> ArgOcc
	 -> UniqSM (Bool, CoreArg)
-- Returns (interesting, pat), 
-- where pat is the pattern derived from the argument
--	      intersting=True if the pattern is non-trivial (not a variable or type)
-- E.g.		x:xs	     --> (True, x:xs)
--		f xs         --> (False, w)	   where w is a fresh wildcard
--		(f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
--		\x. x+y      --> (True, \x. x+y)
--		lvl7	     --> (True, lvl7)	   if lvl7 is bound 
--						   somewhere further out

argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
  = return (False, arg)

argToPat env in_scope val_env (Note _ arg) arg_occ
  = argToPat env in_scope val_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 env in_scope val_env (Let _ arg) arg_occ
  = argToPat env in_scope val_env arg arg_occ
	-- See Note [Matching lets] in Rule.lhs
	-- Look through let expressions
	-- e.g.		f (let v = rhs in (v,w))
	-- Here we can specialise for f (v,w)
	-- because the rule-matcher will look through the let.

{- Disabled; see Note [Matching cases] in Rule.lhs
argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
  | exprOkForSpeculation scrut	-- See Note [Matching cases] in Rule.hhs
  = argToPat env in_scope val_env rhs arg_occ
-}

argToPat env in_scope val_env (Cast arg co) arg_occ
  | not (ignoreType env ty2)
  = do	{ (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
	; if not interesting then 
		wildCardPat ty2
	  else do
	{ -- Make a wild-card pattern for the coercion
	  uniq <- getUniqueUs
	; let co_name = mkSysTvName uniq (fsLit "sg")
	      co_var = mkCoVar co_name (mkCoKind ty1 ty2)
	; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
  where
    (ty1, ty2) = coercionKind co

    

{-	Disabling lambda specialisation for now
	It's fragile, and the spec_loop can be infinite
argToPat in_scope val_env arg arg_occ
  | is_value_lam arg
  = return (True, arg)
  where
    is_value_lam (Lam v e) 	-- Spot a value lambda, even if 
	| isId v = True		-- it is inside a type lambda
	| 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 env in_scope val_env arg arg_occ
  | Just (ConVal dc args) <- isValue val_env arg
  , not (ignoreAltCon env dc)
  , case arg_occ of
	ScrutOcc _ -> True		-- Used only by case scrutinee
	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 env in_scope val_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 env in_scope val_env (Var v) arg_occ
  | case arg_occ of { UnkOcc -> False; _other -> True },	-- (a)
    is_value,							-- (b)
    not (ignoreType env (varType v))
  = return (True, Var v)
  where
    is_value 
	| isLocalId v = v `elemInScopeSet` in_scope 
			&& isJust (lookupVarEnv val_env v)
		-- Local variables have values in val_env
	| otherwise   = isValueUnfolding (idUnfolding v)
		-- Imports have unfoldings

--	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 _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 _env _in_scope _val_env arg _arg_occ
  = wildCardPat (exprType arg)

wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat ty = do { uniq <- getUniqueUs
		    ; let id = mkSysLocal (fsLit "sc") uniq ty
		    ; return (False, Var id) }

argsToPats :: ScEnv -> InScopeSet -> ValueEnv
	   -> [(CoreArg, ArgOcc)]
	   -> UniqSM [(Bool, CoreArg)]
argsToPats env in_scope val_env args
  = mapM do_one args
  where
    do_one (arg,occ) = argToPat env in_scope val_env arg occ

isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue _env (Lit lit)
  = Just (ConVal (LitAlt lit) [])

isValue env (Var v)
  | 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

  | not (isLocalId v) && isCheapUnfolding unf
  = isValue env (unfoldingTemplate unf)
  where
    unf = idUnfolding v
	-- However we do want to consult the unfolding 
	-- as well, for let-bound constructors!

isValue env (Lam b e)
  | isTyCoVar b = case isValue env e of
		  Just _  -> Just LambdaVal
		  Nothing -> Nothing
  | otherwise = Just LambdaVal

isValue _env expr	-- Maybe it's a constructor application
  | (Var fun, args) <- collectArgs expr
  = case isDataConWorkId_maybe fun of

	Just con | args `lengthAtLeast` dataConRepArity con 
		-- Check saturated; might be > because the 
		--		    arity excludes type args
		-> Just (ConVal (DataAlt con) args)

	_other | valArgCount args < idArity fun
		-- Under-applied function
	       -> Just LambdaVal	-- Partial application

	_other -> Nothing

isValue _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 _other _args = panic "SpecConstr.mk_con_app"

samePat :: CallPat -> CallPat -> Bool
samePat (vs1, as1) (vs2, as2)
  = all2 same as1 as2
  where
    same (Var v1) (Var v2) 
	| v1 `elem` vs1 = v2 `elem` vs2
	| v2 `elem` vs2 = False
	| otherwise     = v1 == v2

    same (Lit l1)    (Lit l2)    = l1==l2
    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2

    same (Type {}) (Type {}) = True	-- Note [Ignore type differences]
    same (Note _ e1) e2	= same e1 e2	-- Ignore casts and notes
    same (Cast e1 _) e2	= same e1 e2
    same e1 (Note _ e2) = same e1 e2
    same e1 (Cast e2 _) = same e1 e2

    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) 
		 False 	-- Let, lambda, case should not occur
    bad (Case {}) = True
    bad (Let {})  = True
    bad (Lam {})  = True
    bad _other	  = False