+
+-- In which phase should the specialise-constructor rules be active?
+-- Originally I made them always-active, but Manuel found that
+-- this defeated some clever user-written rules. So Plan B
+-- is to make them active only in Phase 0; after all, currently,
+-- the specConstr transformation is only run after the simplifier
+-- has reached Phase 0. In general one would want it to be
+-- flag-controllable, but for now I'm leaving it baked in
+-- [SLPJ Oct 01]
+specConstrActivation :: Activation
+specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Argument analysis}
+%* *
+%************************************************************************
+
+This code deals with analysing call-site arguments to see whether
+they are constructor applications.
+
+\begin{code}
+ -- 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 :: ConstrEnv -> UniqSupply -> CoreArg -> (UniqSupply, CoreExpr)
+argToPat env us (Type ty)
+ = (us, Type ty)
+
+argToPat env us arg
+ | Just (CV dc args) <- is_con_app_maybe env arg
+ = let
+ (us',args') = argsToPats env us args
+ in
+ (us', mk_con_app dc args')
+
+argToPat env us (Var v) -- Don't uniqify existing vars,
+ = (us, Var v) -- so that we can spot when we pass them twice
+
+argToPat env us arg
+ = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
+ where
+ (us1,us2) = splitUniqSupply us
+
+argsToPats :: ConstrEnv -> UniqSupply -> [CoreArg] -> (UniqSupply, [CoreExpr])
+argsToPats env us args = mapAccumL (argToPat env) us args
+\end{code}
+
+
+\begin{code}
+is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
+is_con_app_maybe env (Var v)
+ = lookupVarEnv env v
+ -- 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
+
+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)
+
+ other -> Nothing
+
+mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
+mk_con_app (LitAlt lit) [] = Lit lit
+mk_con_app (DataAlt con) args = mkConApp con args