module HERMIT.Dictionary.GHC
(
externals
, substR
, substCoreAlt
, substCoreExpr
, dynFlagsT
, arityOf
, lintExprT
, lintModuleT
, occurAnalyseR
, occurAnalyseChangedR
, occurAnalyseExprChangedR
, occurAnalyseAndDezombifyR
, dezombifyR
)
where
import qualified Bag
import qualified CoreLint
import Control.Arrow
import Data.List (mapAccumL)
import HERMIT.Core
import HERMIT.Context
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Dictionary.Debug hiding (externals)
externals :: [External]
externals =
[ external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core)
[ "Deshadow a program." ] .+ Deep
, 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 :: TransformH CoreTC 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 :: TransformH CoreTC String)
[ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query
]
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 (arr $ substCoreAlt 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))
substCoreAlt :: Var -> CoreExpr -> CoreAlt -> CoreAlt
substCoreAlt v e alt = let (con, vs, rhs) = alt
inS = (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) alt
subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e
(subst', vs') = substBndrs subst vs
in (con, vs', substExpr (text "alt-rhs") subst' rhs)
deShadowProgR :: Monad m => Rewrite c m CoreProg
deShadowProgR = arr (bindsToProg . deShadowBinds . progToBinds)
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 :: TransformH 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) => Transform c m CoreExpr String
lintExprT = transform $ \ 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
dynFlagsT :: HasDynFlags m => Transform 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, HasEmptyContext c, 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, HasEmptyContext c, MonadCatch m) => Rewrite c m Core
occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR
occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core
occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR
occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, HasEmptyContext c, MonadCatch m) => Rewrite c m Core
occurrenceAnalysisR = occurAnalyseAndDezombifyR