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` mkVarUsage env fn' args',
                               mkApps (Var fn') args')

	    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') }

----------------------
mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
mkVarUsage env fn args
  = 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 arg_occ }
        Nothing     -> nullUsage
  where
    -- I rather think we could use UnkOcc all the time
    arg_occ | null args = UnkOcc
            | otherwise = evalScrutOcc

----------------------
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 (scForce 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] ++ 
    	      -- First the specialised bindings

    [(fn `addIdSpecialisations` rules, new_rhs)]
    	      -- And now the original binding
  where
    rules = [r | OS _ r _ _ <- specs]

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)	-- Just cs  => we have not yet used calls in the
					--	       from calls in the *original* RHS as
				 	--	       seeds for new specialisations;
					--	       if you decide to do so, here is the
					-- 	       RHS usage (which has not yet been
					--	       unleashed)
					-- Nothing => we have
					-- 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
	 -> 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
   -> RhsInfo
   -> SpecInfo				-- Original RHS plus patterns dealt with
   -> UniqSM (ScUsage, SpecInfo)	-- New specialised versions and their usage

-- Note: this only generates *specialised* bindings
-- The original binding is added by specInfoBinds
--
-- 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 (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 (sc_force env) && spec_count' > max
		-> if (debugIsOn || opt_PprStyle_Debug)	 -- Suppress this scary message for
                   then pprTrace "SpecConstr" msg $  	 -- ordinary users!  Trac #5125
                        return (nullUsage, spec_info)
                   else 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 ds (Coercion {} : 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 :: [CallPat]
	      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)
	; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
	; let pat_fvs = varSetElems (exprsFreeVars pats)
	      in_scope_vars = getInScopeVars in_scope
	      qvars   = filterOut (`elemVarSet` in_scope_vars) pat_fvs
		-- Quantify over variables that are not in sccpe
		-- at the call site
		-- See Note [Free type variables of the qvar types]
		-- See Note [Shadowing] at the top
		
	      (tvs, ids) = partition isTyVar qvars
	      qvars'     = tvs ++ map sanitise ids
		-- Put the type variables first; the type of a term
		-- variable may mention a type variable

	      sanitise id = id `setIdType` expandTypeSynonyms (idType id)
	        -- See Note [Free type variables of the qvar types]

	; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
	  if interesting
	  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
--	      interesting=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 arg@(Coercion {}) _arg_occ
  = return (False, arg)

argToPat env in_scope val_env (Tick _ 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
  | isReflCo co     -- Substitution in the SpecConstr itself
                    -- can lead to identity coercions
  = argToPat env in_scope val_env arg 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 (mkCoercionType ty1 ty2)
	; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
  where
    Pair 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 (DataAlt dc) args) <- isValue val_env arg
  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
  , Just arg_occs <- mb_scrut dc
  = do	{ let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
	; return (True, 
                  mkConApp dc (ty_args ++ args')) }
  where
    mb_scrut dc = case arg_occ of
    	            ScrutOcc bs 
                           | Just occs <- lookupUFM bs dc
                                          -> Just (occs)  -- See Note [Reboxing]
                    _other | sc_force env -> Just (repeat UnkOcc)
                           | otherwise    -> Nothing

  -- Check if the argument is a variable that 
  --	(a) is used in an interesting way in the body
  --	(b) we know what its value is
  -- In that case it counts as "interesting"
argToPat env in_scope val_env (Var v) arg_occ
  | sc_force env || 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]  -- Should be same length
	   -> UniqSM (Bool, [CoreArg])
argsToPats env in_scope val_env args occs
  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
       ; let (interesting_s, args') = unzip stuff
       ; return (or interesting_s, args') }

isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue _env (Lit lit)
  | litIsLifted lit = Nothing
  | otherwise       = 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)
  | isTyVar 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

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 (Coercion {}) (Coercion {}) = True
    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
    same (Cast e1 _) e2	= same e1 e2
    same e1 (Tick _ 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