module HERMIT.Dictionary.Inline
(
externals
, InlineConfig(..)
, CaseBinderInlineOption(..)
, getUnfoldingT
, getUnfoldingsT
, ensureBoundT
, inlineR
, inlineNameR
, inlineNamesR
, inlineMatchingPredR
, inlineCaseScrutineeR
, inlineCaseAlternativeR
, configurableInlineR
, inlineTargetsT
) where
import Control.Arrow
import Control.Monad
import HERMIT.Context
import HERMIT.Core
import HERMIT.External
import HERMIT.GHC
import HERMIT.Kure
import HERMIT.Name
import HERMIT.Dictionary.Common
externals :: [External]
externals =
[ external "inline" (promoteExprR inlineR :: RewriteH LCore)
[ "(Var v) ==> <defn of v>" ].+ Eval .+ Deep
, external "inline" (promoteExprR . inlineMatchingPredR . mkOccPred :: OccurrenceName -> RewriteH LCore)
[ "Given a specific v, (Var v) ==> <defn of v>" ] .+ Eval .+ Deep
, external "inline" (promoteExprR . inlineNamesR :: [String] -> RewriteH LCore)
[ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep
, external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH LCore)
[ "if v is a case binder, replace (Var v) with the bound case scrutinee." ] .+ Eval .+ Deep
, external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH LCore)
[ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep
]
data CaseBinderInlineOption = Scrutinee | Alternative deriving (Eq, Show)
data InlineConfig = CaseBinderOnly CaseBinderInlineOption | AllBinders deriving (Eq, Show)
inlineNameR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> String -> Rewrite c m CoreExpr
inlineNameR nm = inlineMatchingPredR (cmpString2Var nm)
inlineNamesR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> [String] -> Rewrite c m CoreExpr
inlineNamesR [] = fail "inline-names failed: no names given."
inlineNamesR nms = inlineMatchingPredR (\ v -> any (flip cmpString2Var v) nms)
inlineMatchingPredR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> (Id -> Bool) -> Rewrite c m CoreExpr
inlineMatchingPredR idPred = configurableInlineR AllBinders (arr $ idPred)
inlineR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c,
ReadBindings c, ReadPath c Crumb, MonadCatch m )
=> Rewrite c m CoreExpr
inlineR = configurableInlineR AllBinders (return True)
inlineCaseScrutineeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> Rewrite c m CoreExpr
inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True)
inlineCaseAlternativeR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> Rewrite c m CoreExpr
inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True)
configurableInlineR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c
, ReadPath c Crumb, MonadCatch m )
=> InlineConfig
-> (Transform c m Id Bool)
-> Rewrite c m CoreExpr
configurableInlineR config p =
prefixFailMsg "Inline failed: " $
do b <- varT p
guardMsg b "identifier does not satisfy predicate."
(e,uncaptured) <- varT (getUnfoldingT config)
return e >>> ensureBoundT
setFailMsg "values in inlined expression have been rebound."
(return e >>> accepterR (ensureDepthT uncaptured))
ensureBoundT :: (Monad m, ReadBindings c) => Transform c m CoreExpr ()
ensureBoundT = do
unbound <- transform $ \ c -> return . filterVarSet (not . inScope c) . localFreeVarsExpr
guardMsg (isEmptyVarSet unbound) $ "the following variables are unbound: " ++ showVarSet unbound
ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c, MonadCatch m) => (BindingDepth -> Bool) -> Transform c m CoreExpr Bool
ensureDepthT uncaptured =
do frees <- arr localFreeVarsExpr
let collectDepthsT :: Transform c m Core [BindingDepth]
collectDepthsT = collectT $ promoteExprT $ varT (acceptR (`elemVarSet` frees) >>> readerT varBindingDepthT)
all uncaptured `liftM` extractT collectDepthsT
getUnfoldingT :: (ReadBindings c, MonadCatch m)
=> InlineConfig
-> Transform c m Id (CoreExpr, BindingDepth -> Bool)
getUnfoldingT config = do
r <- getUnfoldingsT config
case r of
[] -> fail "no unfolding for variable."
(u:_) -> return u
getUnfoldingsT :: (ReadBindings c, MonadCatch m)
=> InlineConfig
-> Transform c m Id [(CoreExpr, BindingDepth -> Bool)]
getUnfoldingsT config = transform $ \ c i ->
case lookupHermitBinding i c of
Nothing -> do requireAllBinders config
let uncaptured = (<= 0)
guardMsg (isId i) "type variable is not in Env (this should not happen)."
case unfoldingInfo (idInfo i) of
CoreUnfolding { uf_tmpl = uft } -> single (uft, uncaptured)
dunf@(DFunUnfolding {}) -> single . (,uncaptured) =<< dFunExpr dunf
_ -> fail $ "cannot find unfolding in Env or IdInfo."
Just b -> let depth = hbDepth b
in case hbSite b of
CASEBINDER s alt -> let tys = tyConAppArgs (idType i)
altExprDepthM = single . (, (<= depth+1)) =<< alt2Exp tys alt
scrutExprDepthM = single (s, (< depth))
in case config of
CaseBinderOnly Scrutinee -> scrutExprDepthM
CaseBinderOnly Alternative -> altExprDepthM
AllBinders -> do
au <- altExprDepthM <+ return []
su <- scrutExprDepthM
return $ au ++ su
NONREC e -> do requireAllBinders config
single (e, (< depth))
REC e -> do requireAllBinders config
single (e, (<= depth))
MUTUALREC e -> do requireAllBinders config
single (e, (<= depth+1))
TOPLEVEL e -> do requireAllBinders config
single (e, (<= depth))
_ -> fail "variable is not bound to an expression."
where
single = return . (:[])
requireAllBinders :: Monad m => InlineConfig -> m ()
requireAllBinders AllBinders = return ()
requireAllBinders (CaseBinderOnly _) = fail "not a case binder."
alt2Exp :: Monad m => [Type] -> (AltCon,[Var]) -> m CoreExpr
alt2Exp _ (DEFAULT , _ ) = fail "DEFAULT alternative cannot be converted to an expression."
alt2Exp _ (LitAlt l , _ ) = return $ Lit l
alt2Exp tys (DataAlt dc, vs) = return $ mkDataConApp tys dc vs
inlineTargetsT :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c
, ReadBindings c, HasEmptyContext c, MonadCatch m )
=> Transform c m LCore [String]
inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr unqualifiedName)
dFunExpr :: Monad m => Unfolding -> m CoreExpr
dFunExpr dunf@(DFunUnfolding {}) = return $ mkCoreLams (df_bndrs dunf) $ mkCoreConApps (df_con dunf) (df_args dunf)
dFunExpr _ = fail "dFunExpr: not a DFunUnfolding"