module HERMIT.Dictionary.GHC
(
externals
, substR
, substCoreAlt
, substCoreExpr
, dynFlagsT
, arityOf
, lintExprT
, lintModuleT
, occurAnalyseR
, occurAnalyseChangedR
, occurAnalyseExprChangedR
, occurAnalyseAndDezombifyR
, dezombifyR
, buildDictionary
, buildDictionaryT
, buildTypeable
) where
import qualified Bag
import qualified CoreLint
import Control.Arrow
import Control.Monad.IO.Class
import Data.Char (isSpace)
import Data.List (mapAccumL)
import HERMIT.Core
import HERMIT.Context
import HERMIT.Dictionary.Debug hiding (externals)
import HERMIT.External
import HERMIT.GHC
import HERMIT.Kure
import HERMIT.Monad
import HERMIT.Name
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
let (warns, errs) = CoreLint.lintCoreBindings [] bnds
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)
$ CoreLint.lintExpr (varSetElems $ boundVars c) e
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_NoBinderSwap)
go = r <+ anyR go
in tryR go
occurAnalyseExprChangedR :: MonadCatch m => Rewrite c m CoreExpr
occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr_NoBinderSwap)
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
buildTypeable :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Type -> m (Id, [CoreBind])
buildTypeable ty = do
evar <- runTcM $ do
cls <- tcLookupClass typeableClassName
let predTy = mkClassPred cls [typeKind ty, ty]
newWantedEvVar predTy
buildDictionary evar
buildDictionary :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadIO m) => Id -> m (Id, [CoreBind])
buildDictionary evar = do
(i, bs) <- runTcM $ do
loc <- getCtLoc $ GivenOrigin UnkSkol
let predTy = varType evar
nonC = mkNonCanonical $ CtWanted { ctev_pred = predTy, ctev_evar = evar, ctev_loc = loc }
wCs = mkFlatWC [nonC]
(wCs', bnds) <- solveWantedsTcM wCs
reportAllUnsolved wCs'
return (evar, bnds)
bnds <- runDsM $ dsEvBinds bs
return (i,bnds)
buildDictionaryT :: (HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadUnique m)
=> Transform c m Type CoreExpr
buildDictionaryT = prefixFailMsg "buildDictionaryT failed: " $ contextfreeT $ \ ty -> do
dflags <- getDynFlags
binder <- newIdH ("$d" ++ zEncodeString (filter (not . isSpace) (showPpr dflags ty))) ty
(i,bnds) <- buildDictionary binder
guardMsg (notNull bnds) "no dictionary bindings generated."
return $ case bnds of
[NonRec v e] | i == v -> e
_ -> mkCoreLets bnds (varToCoreExpr i)