module Language.HERMIT.Primitive.Inline
(
externals
, inline
, inlineName
, inlineScrutinee
, inlineCaseBinder
, inlineTargets
)
where
import GhcPlugins
import Control.Arrow
import Language.HERMIT.Core
import Language.HERMIT.Kure
import Language.HERMIT.Context
import Language.HERMIT.GHC
import Language.HERMIT.External
import Language.HERMIT.Primitive.Common
import Language.HERMIT.Primitive.GHC hiding (externals)
import Language.HERMIT.Primitive.Unfold hiding (externals)
import qualified Language.Haskell.TH as TH
externals :: [External]
externals =
[ external "inline" (promoteExprR inline :: RewriteH Core)
[ "(Var n) ==> <defn of n>, fails otherwise" ].+ Eval .+ Deep .+ TODO
, external "inline-scrutinee" (promoteExprR inlineScrutinee :: RewriteH Core)
[ "(Var n) ==> <defn of n>, fails otherwise"
, "In the case of case binders, replaces with scrutinee expression, "
, "rather than constructor or literal." ].+ Eval .+ Deep .+ TODO
, external "inline" (promoteExprR . inlineName :: TH.Name -> RewriteH Core)
[ "Restrict inlining to a given name" ].+ Eval .+ Deep .+ TODO
, external "inline-case-binder" (promoteExprR inlineCaseBinder :: RewriteH Core)
[ "Inline if this variable is a case binder." ].+ Eval .+ Deep .+ Bash .+ TODO
]
inlineName :: TH.Name -> RewriteH CoreExpr
inlineName nm = let name = TH.nameBase nm in
prefixFailMsg ("inline '" ++ name ++ " failed: ") $
withPatFailMsg (wrongExprForm "Var v") $
do Var v <- idR
guardMsg (cmpTHName2Var nm v) $ " does not match " ++ var2String v ++ "."
inline
inline :: RewriteH CoreExpr
inline = configurableInline False False
inlineScrutinee :: RewriteH CoreExpr
inlineScrutinee = configurableInline True False
inlineCaseBinder :: RewriteH CoreExpr
inlineCaseBinder = configurableInline False True
configurableInline :: Bool
-> Bool
-> RewriteH CoreExpr
configurableInline scrutinee caseBinderOnly =
prefixFailMsg "Inline failed: " $
withPatFailMsg (wrongExprForm "Var v") $
do (c, Var v) <- exposeT
(e,d) <- getUnfolding scrutinee caseBinderOnly v c
return e >>> accepterR (extractT $ ensureDepth d) "values in inlined expression have been rebound."
ensureDepth :: Int -> TranslateH Core Bool
ensureDepth d = do
frees <- promoteT freeVarsT
ds <- collectT $ do c <- contextT
promoteExprT $ varT $ \ i -> if i `elem` frees
then maybe (i,0) (\b -> (i,hermitBindingDepth b)) (lookupHermitBinding i c)
else (i,0)
return $ all (toSnd (<= d)) ds
inlineTargets :: TranslateH Core [String]
inlineTargets = collectT $ promoteT $ whenM (testM inline) (varT unqualifiedVarName)