module HERMIT.Dictionary.Inline
(
externals
, InlineConfig(..)
, CaseBinderInlineOption(..)
, getUnfoldingT
, inlineR
, inlineNameR
, inlineNamesR
, inlineCaseScrutineeR
, inlineCaseAlternativeR
, configurableInlineR
, inlineTargetsT
)
where
#if __GLASGOW_HASKELL__ > 706
#else
import TcType (tcSplitDFunTy)
#endif
import Control.Arrow
import Control.Applicative
import Control.Monad
import HERMIT.Context
import HERMIT.Core
import HERMIT.External
import HERMIT.GHC
import HERMIT.Kure
import HERMIT.Monad
import HERMIT.Dictionary.Common
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "inline" (promoteExprR inlineR :: RewriteH Core)
[ "(Var v) ==> <defn of v>" ].+ Eval .+ Deep
, external "inline" (promoteExprR . inlineNameR :: TH.Name -> RewriteH Core)
[ "Given a specific v, (Var v) ==> <defn of v>" ] .+ Eval .+ Deep
, external "inline" (promoteExprR . inlineNamesR :: [TH.Name] -> RewriteH Core)
[ "If the current variable matches any of the given names, then inline it." ] .+ Eval .+ Deep
, external "inline-case-scrutinee" (promoteExprR inlineCaseScrutineeR :: RewriteH Core)
[ "if v is a case binder, replace (Var v) with the bound case scrutinee." ] .+ Eval .+ Deep
, external "inline-case-alternative" (promoteExprR inlineCaseAlternativeR :: RewriteH Core)
[ "if v is a case binder, replace (Var v) with the bound case-alternative pattern." ] .+ Eval .+ Deep .+ Unsafe
]
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) => TH.Name -> Rewrite c HermitM CoreExpr
inlineNameR nm = configurableInlineR AllBinders (arr $ cmpTHName2Var nm)
inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr
inlineNamesR [] = fail "inline-names failed: no names given."
inlineNamesR nms = configurableInlineR AllBinders (arr $ \ v -> any (flip cmpTHName2Var v) nms)
inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr
inlineR = configurableInlineR AllBinders (return True)
inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr
inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True)
inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr
inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True)
configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c)
=> InlineConfig
-> (Translate c HermitM Id Bool)
-> Rewrite c HermitM CoreExpr
configurableInlineR config p =
prefixFailMsg "Inline failed: " $
do b <- varT p
guardMsg b "identifier does not satisfy predicate."
(e,uncaptured) <- varT (getUnfoldingT config)
setFailMsg "values in inlined expression have been rebound."
(return e >>> accepterR (ensureDepthT uncaptured))
ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool
ensureDepthT uncaptured =
do frees <- arr localFreeVarsExpr
let collectDepthsT :: Translate c m Core [BindingDepth]
collectDepthsT = collectT $ promoteExprT $ varT (acceptR (`elemVarSet` frees) >>> readerT varBindingDepthT)
all uncaptured `liftM` extractT collectDepthsT
getUnfoldingT :: ReadBindings c
=> InlineConfig
-> Translate c HermitM Id (CoreExpr, BindingDepth -> Bool)
getUnfoldingT config = translate $ \ c i ->
case lookupHermitBinding i c of
Nothing -> do requireAllBinders config
let uncaptured = (<= 0)
case unfoldingInfo (idInfo i) of
CoreUnfolding { uf_tmpl = uft } -> return (uft, uncaptured)
#if __GLASGOW_HASKELL__ > 706
dunf@(DFunUnfolding {}) -> (,uncaptured) <$> dFunExpr dunf
#else
DFunUnfolding _arity dc args -> (,uncaptured) <$> dFunExpr dc args (idType i)
#endif
_ -> fail $ "cannot find unfolding in Env or IdInfo."
Just b -> let depth = hbDepth b
in case hbSite b of
CASEWILD s alt -> let tys = tyConAppArgs (idType i)
altExprDepthM = (, (<= depth+1)) <$> alt2Exp tys alt
scrutExprDepthM = return (s, (< depth))
in case config of
CaseBinderOnly Scrutinee -> scrutExprDepthM
CaseBinderOnly Alternative -> altExprDepthM
AllBinders -> altExprDepthM <+ scrutExprDepthM
NONREC e -> do requireAllBinders config
return (e, (< depth))
REC e -> do requireAllBinders config
return (e, (<= depth))
MUTUALREC e -> do requireAllBinders config
return (e, (<= depth+1))
_ -> fail "variable is not bound to an expression."
where
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 $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs)
inlineTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String]
inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr var2String)
#if __GLASGOW_HASKELL__ > 706
dFunExpr :: Unfolding -> HermitM CoreExpr
dFunExpr dunf@(DFunUnfolding {}) = return $ trace "dFunExpr" $ mkCoreConApps (df_con dunf) (df_args dunf)
dFunExpr _ = fail "dFunExpr: not a DFunUnfolding"
#else
dFunExpr :: DataCon -> [DFunArg CoreExpr] -> Type -> HermitM CoreExpr
dFunExpr dc args ty = do
let (_, _, _, tcArgs) = tcSplitDFunTy ty
(forallTvs, ty') = splitForAllTys ty
(argTys, _resTy) = splitFunTys ty'
ids <- mapM (uncurry newIdH) $ zip [ [ch] | ch <- cycle ['a'..'z'] ] argTys
vars <- mapM (cloneVarH id) forallTvs
let allVars = varsToCoreExprs $ vars ++ ids
mkArg (DFunLamArg i) = allVars !! i
mkArg (DFunPolyArg e) = mkCoreApps e allVars
return $ mkCoreConApps dc $ map Type tcArgs ++ map mkArg args
#endif