+type IdAppInfo = (Id, SATInfo)
+
+type SATInfo = [Staticness App]
+type IdSATInfo = IdEnv SATInfo
+emptyIdSATInfo :: IdSATInfo
+emptyIdSATInfo = emptyUFM
+
+{-
+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))
+ where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
+-}
+
+pprSATInfo :: SATInfo -> SDoc
+pprSATInfo staticness = hcat $ map pprStaticness staticness
+
+pprStaticness :: Staticness App -> SDoc
+pprStaticness (Static (VarApp _)) = ptext (sLit "SV")
+pprStaticness (Static (TypeApp _)) = ptext (sLit "ST")
+pprStaticness (Static (CoApp _)) = ptext (sLit "SC")
+pprStaticness NotStatic = ptext (sLit "NS")
+
+
+mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
+mergeSATInfo [] _ = []
+mergeSATInfo _ [] = []
+mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps
+mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps
+mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ")
+ <> ptext (sLit "Right:") <> pprSATInfo r
+
+mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
+mergeIdSATInfo = plusUFM_C mergeSATInfo
+
+mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
+
+bindersToSATInfo :: [Id] -> SATInfo
+bindersToSATInfo vs = map (Static . binderToApp) vs
+ where binderToApp v | isId v = VarApp v
+ | isTyVar v = TypeApp $ mkTyVarTy v
+ | otherwise = CoApp $ mkCoVarCo v
+
+finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
+finalizeApp Nothing id_sat_info = id_sat_info
+finalizeApp (Just (v, sat_info')) id_sat_info =
+ let sat_info'' = case lookupUFM id_sat_info v of
+ Nothing -> sat_info'
+ Just sat_info -> mergeSATInfo sat_info sat_info'
+ in extendVarEnv id_sat_info v sat_info''
+\end{code}
+\begin{code}
+satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
+satTopLevelExpr expr interesting_ids = do
+ (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+ return (expr', finalizeApp expr_app sat_info_expr)
+
+satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+satExpr var@(Var v) interesting_ids = do
+ let app_info = if v `elementOfUniqSet` interesting_ids
+ then Just (v, [])
+ else Nothing
+ return (var, emptyIdSATInfo, app_info)
+
+satExpr lit@(Lit _) _ = do
+ return (lit, emptyIdSATInfo, Nothing)
+
+satExpr (Lam binders body) interesting_ids = do
+ (body', sat_info, this_app) <- satExpr body interesting_ids
+ return (Lam binders body', finalizeApp this_app sat_info, Nothing)
+
+satExpr (App fn arg) interesting_ids = do
+ (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids
+ let satRemainder = boring fn' sat_info_fn
+ case fn_app of
+ Nothing -> satRemainder Nothing
+ Just (fn_id, fn_app_info) ->
+ -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
+ let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
+ in case arg of
+ Type t -> satRemainderWithStaticness $ Static (TypeApp t)
+ Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+ Var v -> satRemainderWithStaticness $ Static (VarApp v)
+ _ -> satRemainderWithStaticness $ NotStatic
+ where
+ boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+ boring fn' sat_info_fn app_info =
+ do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids
+ let sat_info_arg' = finalizeApp arg_app sat_info_arg
+ sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'
+ return (App fn' arg', sat_info, app_info)
+
+satExpr (Case expr bndr ty alts) interesting_ids = do
+ (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+ let sat_info_expr' = finalizeApp expr_app sat_info_expr
+
+ zipped_alts' <- mapM satAlt alts
+ let (alts', sat_infos_alts) = unzip zipped_alts'
+ return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)