module HERMIT.Dictionary.GHC
(
externals
, anyCallR
, substR
, substAltR
, substCoreExpr
, inScope
, rule
, rules
, dynFlagsT
, arityOf
, lintExprT
, lintModuleT
, specConstrR
, occurAnalyseR
, occurAnalyseChangedR
, occurAnalyseExprChangedR
, occurAnalyseAndDezombifyR
, dezombifyR
)
where
import qualified Bag
import qualified CoreLint
import IOEnv hiding (liftIO)
import qualified SpecConstr
import qualified Specialise
import Control.Arrow
import Control.Monad
import Data.Function (on)
import Data.List (mapAccumL,deleteFirstsBy)
import HERMIT.Core
import HERMIT.Context
import HERMIT.Monad
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Dictionary.Debug hiding (externals)
import HERMIT.Dictionary.Kure (unitT)
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core)
[ "Deshadow a program." ] .+ Deep
, external "apply-rule" (promoteExprR . rule :: String -> RewriteH Core)
[ "Apply a named GHC rule" ] .+ Shallow
, external "apply-rule" (rules_help :: TranslateH Core String)
[ "List rules that can be used" ] .+ Query
, external "apply-rules" (promoteExprR . rules :: [String] -> RewriteH Core)
[ "Apply named GHC rules, succeed if any of the rules succeed" ] .+ Shallow
, external "add-rule" ((\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) :: String -> TH.Name -> RewriteH Core)
[ "add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"] .+ Introduce
, external "dezombify" (promoteExprR dezombifyR :: RewriteH Core)
[ "Zap the occurrence information in the current identifer if it is a zombie."] .+ Shallow
, external "occurrence-analysis" (occurrenceAnalysisR :: RewriteH Core)
[ "Perform dependency analysis on all sub-expressions; simplifying and updating identifer info."] .+ Deep
, external "lint-expr" (promoteExprT lintExprT :: TranslateH Core String)
[ "Runs GHC's Core Lint, which typechecks the current expression."
, "Note: this can miss several things that a whole-module core lint will find."
, "For instance, running this on the RHS of a binding, the type of the RHS will"
, "not be checked against the type of the binding. Running on the whole let expression"
, "will catch that however."] .+ Deep .+ Debug .+ Query
, external "lint-module" (promoteModGutsT lintModuleT :: TranslateH Core String)
[ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query
, external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core)
[ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep
, external "specialise" (promoteModGutsR specialise :: RewriteH Core)
[ "Run GHC's specialisation pass, which performs type and dictionary specialization."] .+ Deep
, external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core)
[ "any-call (.. unfold command ..) applies an unfold command to all applications."
, "Preference is given to applications with more arguments." ] .+ Deep
]
substR :: MonadCatch m => Var -> CoreExpr -> Rewrite c m Core
substR v e = setFailMsg "Can only perform substitution on expressions, case alternatives or programs." $
promoteExprR (arr $ substCoreExpr v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e)
substCoreExpr :: Var -> CoreExpr -> (CoreExpr -> CoreExpr)
substCoreExpr v e expr =
let emptySub = mkEmptySubst (mkInScopeSet (localFreeVarsExpr (Let (NonRec v e) expr)))
in substExpr (text "substCoreExpr") (extendSubst emptySub v e) expr
substTopBindR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreProg
substTopBindR v e = contextfreeT $ \ p -> do
let emptySub = emptySubst
return $ bindsToProg $ snd (mapAccumL substBind (extendSubst emptySub v e) (progToBinds p))
substAltR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreAlt
substAltR v e = do
(inS, (c, vs, rhs)) <- arr (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) &&& idR
let subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e
(subst', vs') = substBndrs subst vs
return (c, vs', substExpr (text "alt-rhs") subst' rhs)
deShadowProgR :: Monad m => Rewrite c m CoreProg
deShadowProgR = arr (bindsToProg . deShadowBinds . progToBinds)
#if __GLASGOW_HASKELL__ > 706
rulesToRewriteH :: (ReadBindings c, HasDynFlags m, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr
#else
rulesToRewriteH :: (ReadBindings c, MonadCatch m) => [CoreRule] -> Rewrite c m CoreExpr
#endif
rulesToRewriteH rs = prefixFailMsg "RulesToRewrite failed: " $
withPatFailMsg "rule not matched." $
translate $ \ c e -> do
(Var fn,args) <- return $ collectArgs e
let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- varSetElems (localFreeVarsExpr e) ])
_rough_args = map (const Nothing) args
#if __GLASGOW_HASKELL__ > 706
dflags <- getDynFlags
case lookupRule dflags (in_scope, const NoUnfolding) (const True) fn args [r | r <- rs, ru_fn r == idName fn] of
#else
case lookupRule (const True) (const NoUnfolding) in_scope fn args [r | r <- rs, ru_fn r == idName fn] of
#endif
Nothing -> fail "rule not matched"
Just (r, expr) -> do
let e' = mkApps expr (drop (ruleArity r) args)
if all (inScope c) $ varSetElems $ localFreeVarsExpr e'
then return e'
else fail $ unlines ["Resulting expression after rule application contains variables that are not in scope."
,"This can probably be solved by running the flatten-module command at the top level."]
inScope :: ReadBindings c => c -> Id -> Bool
inScope c v = (v `boundIn` c) ||
case unfoldingInfo (idInfo v) of
CoreUnfolding {} -> True
DFunUnfolding {} -> True
_ -> False
rule :: (ReadBindings c, HasCoreRules c) => String -> Rewrite c HermitM CoreExpr
rule r = do
theRules <- getHermitRules
case lookup r theRules of
Nothing -> fail $ "failed to find rule: " ++ show r
Just rr -> rulesToRewriteH rr
rules :: (ReadBindings c, HasCoreRules c) => [String] -> Rewrite c HermitM CoreExpr
rules = orR . map rule
getHermitRules :: HasCoreRules c => Translate c HermitM a [(String, [CoreRule])]
getHermitRules = contextonlyT $ \ c -> do
rb <- liftCoreM getRuleBase
hscEnv <- liftCoreM getHscEnv
rb' <- liftM eps_rule_base $ liftIO $ runIOEnv () $ readMutVar (hsc_EPS hscEnv)
return [ ( unpackFS (ruleName r), [r] )
| r <- hermitCoreRules c ++ concat (nameEnvElts rb) ++ concat (nameEnvElts rb')
]
rules_help :: HasCoreRules c => Translate c HermitM Core String
rules_help = do
rulesEnv <- getHermitRules
dynFlags <- dynFlagsT
return $ (show (map fst rulesEnv) ++ "\n") ++
showSDoc dynFlags (pprRulesForUser $ concatMap snd rulesEnv)
makeRule :: String -> Id -> CoreExpr -> CoreRule
makeRule rule_name nm = mkRule True
False
(mkFastString rule_name)
NeverActive
(varName nm)
[]
[]
addCoreBindAsRule :: Monad m => String -> TH.Name -> Rewrite c m ModGuts
addCoreBindAsRule rule_name nm = contextfreeT $ \ modGuts ->
case [ (v,e)
| bnd <- mg_binds modGuts
, (v,e) <- bindToVarExprs bnd
, nm `cmpTHName2Var` v
] of
[] -> fail $ "cannot find binding " ++ show nm
[(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts
++ [makeRule rule_name v e]
}
_ -> fail $ "found multiple bindings for " ++ show nm
arityOf :: ReadBindings c => c -> Id -> Int
arityOf c i =
case lookupHermitBinding i c of
Nothing -> idArity i
Just b -> runKureM exprArity
(const 0)
(hermitBindingExpr b)
lintModuleT :: TranslateH ModGuts String
lintModuleT =
do dynFlags <- dynFlagsT
bnds <- arr mg_binds
#if __GLASGOW_HASKELL__ > 706
let (warns, errs) = CoreLint.lintCoreBindings [] bnds
#else
let (warns, errs) = CoreLint.lintCoreBindings bnds
#endif
dumpSDocs endMsg = Bag.foldBag (\ d r -> d ++ ('\n':r)) (showSDoc dynFlags) endMsg
if Bag.isEmptyBag errs
then return $ dumpSDocs "Core Lint Passed" warns
else observeR (dumpSDocs "" errs) >>> fail "Core Lint Failed"
lintExprT :: (BoundVars c, Monad m, HasDynFlags m) => Translate c m CoreExpr String
lintExprT = translate $ \ c e -> do
dflags <- getDynFlags
maybe (return "Core Lint Passed") (fail . showSDoc dflags)
#if __GLASGOW_HASKELL__ > 706
$ CoreLint.lintExpr (varSetElems $ boundVars c) e
#else
$ CoreLint.lintUnfolding noSrcLoc (varSetElems $ boundVars c) e
#endif
specConstrR :: RewriteH ModGuts
specConstrR = prefixFailMsg "spec-constr failed: " $ do
rs <- extractT specRules
e' <- contextfreeT $ liftCoreM . SpecConstr.specConstrProgram
rs' <- return e' >>> extractT specRules
let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs
guardMsg (notNull specRs) "no rules created."
return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))
specialise :: RewriteH ModGuts
specialise = prefixFailMsg "specialisation failed: " $ do
gRules <- arr mg_rules
lRules <- extractT specRules
dflags <- dynFlagsT
guts <- contextfreeT $ liftCoreM . Specialise.specProgram dflags
lRules' <- return guts >>> extractT specRules
let gRules' = mg_rules guts
gSpecRs = deleteFirstsBy ((==) `on` ru_name) gRules' gRules
lSpecRs = deleteFirstsBy ((==) `on` ru_name) lRules' lRules
specRs = gSpecRs ++ lSpecRs
guardMsg (notNull specRs) "no rules created."
liftIO $ putStrLn $ unlines $ map (unpackFS . ru_name) specRs
return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs)))
idSpecRules :: TranslateH Id [CoreRule]
idSpecRules = contextfreeT $ \ i -> let SpecInfo rs _ = specInfo (idInfo i) in return rs
bindSpecRules :: TranslateH CoreBind [CoreRule]
bindSpecRules = recT (\_ -> defT idSpecRules unitT const) concat
<+ nonRecT idSpecRules unitT const
specRules :: TranslateH Core [CoreRule]
specRules = crushtdT $ promoteBindT bindSpecRules
anyCallR :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m)
=> Rewrite c m Core -> Rewrite c m Core
anyCallR rr = prefixFailMsg "any-call failed: " $
readerT $ \ e -> case e of
ExprCore (App {}) -> childR App_Arg rec >+> (rr <+ childR App_Fun rec)
ExprCore (Var {}) -> rr
_ -> anyR rec
where rec :: Rewrite c m Core
rec = anyCallR rr
dynFlagsT :: HasDynFlags m => Translate c m a DynFlags
dynFlagsT = constT getDynFlags
dezombifyR :: (ExtendPath c Crumb, Monad m) => Rewrite c m CoreExpr
dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo)
occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core
occurAnalyseR = let r = promoteExprR (arr occurAnalyseExpr)
go = r <+ anyR go
in tryR go
occurAnalyseExprChangedR :: MonadCatch m => Rewrite c m CoreExpr
occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr)
occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core
occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR
occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core
occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR
occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core
occurrenceAnalysisR = occurAnalyseAndDezombifyR