module HERMIT.Dictionary.Local.Let
(
externals
, letNonRecSubstR
, letNonRecSubstSafeR
, letSubstR
, letSubstSafeR
, letElimR
, letNonRecElimR
, letRecElimR
, progBindElimR
, progBindNonRecElimR
, progBindRecElimR
, letIntroR
, letNonRecIntroR
, progNonRecIntroR
, nonRecIntroR
, letIntroUnfoldingR
, letFloatAppR
, letFloatArgR
, letFloatLetR
, letFloatLamR
, letFloatCaseR
, letFloatCaseAltR
, letFloatCastR
, letFloatExprR
, letFloatTopR
, letFloatInR
, letFloatInAppR
, letFloatInCaseR
, letFloatInLamR
, reorderNonRecLetsR
, letTupleR
, letToCaseR
) where
import Control.Arrow
import Control.Monad
import Control.Monad.IO.Class
import Data.List
import Data.Monoid
import HERMIT.Core
import HERMIT.Context
import HERMIT.Monad
import HERMIT.Kure
import HERMIT.External
import HERMIT.GHC
import HERMIT.Name
import HERMIT.Utilities
import HERMIT.Dictionary.Common
import HERMIT.Dictionary.GHC hiding (externals)
import HERMIT.Dictionary.Inline hiding (externals)
import HERMIT.Dictionary.AlphaConversion hiding (externals)
import HERMIT.Dictionary.Local.Bind hiding (externals)
externals :: [External]
externals =
[ external "let-subst" (promoteExprR letSubstR :: RewriteH Core)
[ "Let substitution: (let x = e1 in e2) ==> (e2[e1/x])"
, "x must not be free in e1." ] .+ Deep .+ Eval
, external "let-subst-safe" (promoteExprR letSubstSafeR :: RewriteH Core)
[ "Safe let substitution"
, "let x = e1 in e2, safe to inline without duplicating work ==> e2[e1/x],"
, "x must not be free in e1." ] .+ Deep .+ Eval
, external "let-nonrec-subst-safe" (promoteExprR letNonRecSubstSafeR :: RewriteH Core)
[ "As let-subst-safe, but does not try to convert a recursive let into a non-recursive let first." ] .+ Deep .+ Eval
, external "let-intro" (promoteExprR . letIntroR :: String -> RewriteH Core)
[ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce
, external "let-intro-unfolding" (promoteExprR . letIntroUnfoldingR :: HermitName -> RewriteH Core)
[ "e => let f' = defn[f'/f] in e[f'/f], name of f is provided" ]
, external "let-elim" (promoteExprR letElimR :: RewriteH Core)
[ "Remove an unused let binding."
, "(let v = e1 in e2) ==> e2, if v is not free in e1 or e2." ] .+ Eval .+ Shallow
, external "let-float-app" (promoteExprR letFloatAppR :: RewriteH Core)
[ "(let v = ev in e) x ==> let v = ev in e x" ] .+ Commute .+ Shallow
, external "let-float-arg" (promoteExprR letFloatArgR :: RewriteH Core)
[ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow
, external "let-float-lam" (promoteExprR letFloatLamR :: RewriteH Core)
[ "The Full Laziness Transformation"
, "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2."
, "If v1 = v2 then v1 will be alpha-renamed." ] .+ Commute .+ Shallow
, external "let-float-let" (promoteExprR letFloatLetR :: RewriteH Core)
[ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow
, external "let-float-case" (promoteExprR letFloatCaseR :: RewriteH Core)
[ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval
, external "let-float-case-alt" (promoteExprR (letFloatCaseAltR Nothing) :: RewriteH Core)
[ "case s of { ... ; p -> let v = ev in e ; ... } "
, "==> let v = ev in case s of { ... ; p -> e ; ... } " ] .+ Commute .+ Shallow .+ Eval
, external "let-float-case-alt" (promoteExprR . letFloatCaseAltR . Just :: Int -> RewriteH Core)
[ "Float a let binding from specified alternative."
, "case s of { ... ; p -> let v = ev in e ; ... } "
, "==> let v = ev in case s of { ... ; p -> e ; ... } " ] .+ Commute .+ Shallow .+ Eval
, external "let-float-cast" (promoteExprR letFloatCastR :: RewriteH Core)
[ "cast (let bnds in e) co ==> let bnds in cast e co" ] .+ Commute .+ Shallow
, external "let-float-top" (promoteProgR letFloatTopR :: RewriteH Core)
[ "v = (let bds in e) : prog ==> bds : v = e : prog" ] .+ Commute .+ Shallow
, external "let-float" (promoteProgR letFloatTopR <+ promoteExprR letFloatExprR :: RewriteH Core)
[ "Float a Let whatever the context." ] .+ Commute .+ Shallow
, external "let-to-case" (promoteExprR letToCaseR :: RewriteH Core)
[ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition
, external "let-float-in" (promoteExprR letFloatInR :: RewriteH Core)
[ "Float-in a let if possible." ] .+ Commute .+ Shallow
, external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)
[ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ] .+ Commute .+ Shallow
, external "let-float-in-case" ((promoteExprR letFloatInCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)
[ "let v = ev in case s of p -> e ==> case (let v = ev in s) of p -> let v = ev in e"
, "if v does not shadow a pattern binder in p" ] .+ Commute .+ Shallow
, external "let-float-in-lam" ((promoteExprR letFloatInLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core)
[ "let v = ev in \\ x -> e ==> \\ x -> let v = ev in e"
, "if v does not shadow x" ] .+ Commute .+ Shallow
, external "reorder-lets" (promoteExprR . reorderNonRecLetsR :: [String] -> RewriteH Core)
[ "Re-order a sequence of nested non-recursive let bindings."
, "The argument list should contain the let-bound variables, in the desired order." ]
, external "let-tuple" (promoteExprR . letTupleR :: String -> RewriteH Core)
[ "Combine nested non-recursive lets into case of a tuple."
, "E.g. let {v1 = e1 ; v2 = e2 ; v3 = e3} in body ==> case (e1,e2,e3) of {(v1,v2,v3) -> body}" ] .+ Commute
, external "prog-bind-elim" (promoteProgR progBindElimR :: RewriteH Core)
[ "Remove unused top-level binding(s)."
, "prog-bind-nonrec-elim <+ prog-bind-rec-elim" ] .+ Eval .+ Shallow
, external "prog-bind-nonrec-elim" (promoteProgR progBindNonRecElimR :: RewriteH Core)
[ "Remove unused top-level binding(s)."
, "v = e : prog ==> prog, if v is not free in prog and not exported." ] .+ Eval .+ Shallow
, external "prog-bind-rec-elim" (promoteProgR progBindRecElimR :: RewriteH Core)
[ "Remove unused top-level binding(s)."
, "v+ = e+ : prog ==> v* = e* : prog, where v* is a subset of v+ consisting"
, "of vs that are free in prog or e+, or exported." ] .+ Eval .+ Shallow
]
letSubstR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr
letSubstR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstR
letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr
letSubstSafeR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstSafeR
letNonRecSubstR :: MonadCatch m => Rewrite c m CoreExpr
letNonRecSubstR = prefixFailMsg "Let substitution failed: " $
withPatFailMsg (wrongExprForm "Let (NonRec v rhs) body") $
do Let (NonRec v rhs) body <- idR
return (substCoreExpr v rhs body)
letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, HasEmptyContext c, MonadCatch m) => Rewrite c m CoreExpr
letNonRecSubstSafeR =
do Let (NonRec v _) _ <- idR
when (isId v) $ guardMsgM (safeSubstT v) "safety criteria not met."
letNonRecSubstR
where
safeSubstT :: Id -> Transform c m CoreExpr Bool
safeSubstT i = letNonRecT mempty safeBindT (safeOccursT i) (\ () -> (||))
safeBindT :: Transform c m CoreExpr Bool
safeBindT =
do c <- contextT
arr $ \ e ->
case e of
Var {} -> True
Lam {} -> True
App {} -> case collectArgs e of
(Var f,args) -> arityOf c f > length (filter (not . isTyCoArg) args)
(other,args) -> case collectBinders other of
(bds,_) -> length bds > length args
_ -> False
safeOccursT :: Id -> Transform c m CoreExpr Bool
safeOccursT i =
do depth <- varBindingDepthT i
let occursHereT :: Transform c m Core ()
occursHereT = promoteExprT (exprIsOccurrenceOfT i depth >>> guardT)
lamOccurrenceT :: Transform c m CoreExpr (Sum Int)
lamOccurrenceT = lamT mempty
(mtryM (Sum 2 <$ extractT (onetdT occursHereT)))
mappend
occurrencesT :: Transform c m Core (Sum Int)
occurrencesT = prunetdT (promoteExprT lamOccurrenceT <+ (Sum 1 <$ occursHereT))
extractT occurrencesT >>^ (getSum >>> (< 2))
(<$) :: Monad m => a -> m b -> m a
a <$ mb = mb >> return a
letElimR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr
letElimR = prefixFailMsg "Let elimination failed: " $
withPatFailMsg (wrongExprForm "Let binds expr") $
do Let bg _ <- idR
case bg of
NonRec{} -> letNonRecElimR
Rec{} -> letRecElimR
letNonRecElimR :: MonadCatch m => Rewrite c m CoreExpr
letNonRecElimR = withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $
do Let (NonRec v _) e <- idR
guardMsg (v `notElemVarSet` freeVarsExpr e) "let-bound variable appears in the expression."
return e
letRecElimR :: MonadCatch m => Rewrite c m CoreExpr
letRecElimR = withPatFailMsg (wrongExprForm "Let (Rec v e1) e2") $
do Let (Rec bnds) body <- idR
let bodyFrees = freeIdsExpr body
bsAndFrees = map (second freeIdsExpr) bnds
usedIds = chaseDependencies bodyFrees bsAndFrees
bs = mkVarSet (map fst bsAndFrees)
liveBinders = bs `intersectVarSet` usedIds
if isEmptyVarSet liveBinders
then return body
else if bs `subVarSet` liveBinders
then fail "no dead binders to eliminate."
else return $ Let (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) body
progBindElimR :: MonadCatch m => Rewrite c m CoreProg
progBindElimR = progBindNonRecElimR <+ progBindRecElimR
progBindNonRecElimR :: MonadCatch m => Rewrite c m CoreProg
progBindNonRecElimR = withPatFailMsg (wrongExprForm "ProgCons (NonRec v e1) e2") $ do
ProgCons (NonRec v _) p <- idR
guardMsg (v `notElemVarSet` freeVarsProg p) "variable appears in program body."
guardMsg (not (isExportedId v)) "variable is exported."
return p
progBindRecElimR :: MonadCatch m => Rewrite c m CoreProg
progBindRecElimR = withPatFailMsg (wrongExprForm "ProgCons (Rec v e1) e2") $
do ProgCons (Rec bnds) p <- idR
let pFrees = freeVarsProg p
bsAndFrees = map (second freeIdsExpr) bnds
usedIds = chaseDependencies pFrees bsAndFrees
bs = mkVarSet (map fst bsAndFrees)
liveBinders = (bs `intersectVarSet` usedIds) `unionVarSet` (filterVarSet isExportedId bs)
if isEmptyVarSet liveBinders
then return p
else if bs `subVarSet` liveBinders
then fail "no dead binders to eliminate."
else return $ ProgCons (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) p
chaseDependencies :: VarSet -> [(Var,VarSet)] -> VarSet
chaseDependencies usedIds bsAndFrees = case partition ((`elemVarSet` usedIds) . fst) bsAndFrees of
([],_) -> usedIds
(used,unused) -> chaseDependencies (unionVarSets (usedIds : map snd used)) unused
letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letToCaseR = prefixFailMsg "Converting Let to Case failed: " $
withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $
do Let (NonRec v ev) _ <- idR
guardMsg (not $ isTyCoArg ev) "cannot case on a type or coercion."
caseBndr <- extractT (cloneVarAvoidingT v Nothing [v])
letT mempty (replaceVarR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')]
letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatAppR = prefixFailMsg "Let floating from App function failed: " $
withPatFailMsg (wrongExprForm "App (Let bnds body) e") $
do App (Let bnds body) e <- idR
let vs = mkVarSet (bindVars bnds) `intersectVarSet` freeVarsExpr e
if isEmptyVarSet vs
then return $ Let bnds (App body e)
else appAllR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatAppR
letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatArgR = prefixFailMsg "Let floating from App argument failed: " $
withPatFailMsg (wrongExprForm "App f (Let bnds body)") $
do App f (Let bnds body) <- idR
let vs = mkVarSet (bindVars bnds) `intersectVarSet` freeVarsExpr f
if isEmptyVarSet vs
then return $ Let bnds (App f body)
else appAllR idR (alphaLetVarsR $ varSetElems vs) >>> letFloatArgR
letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatLetR = prefixFailMsg "Let floating from Let failed: " $
withPatFailMsg (wrongExprForm "Let (NonRec v (Let bds e1)) e2") $
do Let (NonRec v (Let bds e1)) e2 <- idR
let vs = mkVarSet (bindVars bds) `intersectVarSet` freeVarsExpr e2
if isEmptyVarSet vs
then return $ Let bds (Let (NonRec v e1) e2)
else letNonRecAllR idR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatLetR
letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatLamR = prefixFailMsg "Let floating from Lam failed: " $
withPatFailMsg (wrongExprForm "Lam v1 (Let bds body)") $
do Lam v (Let binds body) <- idR
let bs = bindVars binds
fvs = freeVarsBind binds
guardMsg (v `notElemVarSet` fvs) (unqualifiedName v ++ " occurs in the RHS of the let-bindings.")
if v `elem` bs
then alphaLamR Nothing >>> letFloatLamR
else return $ Let binds (Lam v body)
letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatCaseR = prefixFailMsg "Let floating from Case failed: " $
withPatFailMsg (wrongExprForm "Case (Let bnds e) w ty alts") $
do Case (Let bnds e) w ty alts <- idR
let captures = mkVarSet (bindVars bnds) `intersectVarSet` delVarSet (unionVarSets $ map freeVarsAlt alts) w
if isEmptyVarSet captures
then return $ Let bnds (Case e w ty alts)
else caseAllR (alphaLetVarsR $ varSetElems captures) idR idR (const idR) >>> letFloatCaseR
letFloatCaseAltR :: MonadCatch m => Maybe Int -> Rewrite c m CoreExpr
letFloatCaseAltR maybeN = prefixFailMsg "Let float from case alternative failed: " $
withPatFailMsg (wrongExprForm "Case s w ty alts") $ do
let letFloatOneAltM :: MonadCatch m => Id -> VarSet -> [CoreAlt] -> m (CoreBind,[CoreAlt])
letFloatOneAltM w fvs = go
where go [] = fail "no lets can be safely floated from alternatives."
go (alt:rest) = (do (bind,alt') <- letFloatAltM w fvs alt
return (bind,alt':rest))
<+ liftM (second (alt :)) (go rest)
letFloatAltM :: Monad m => Id -> VarSet -> CoreAlt -> m (CoreBind,CoreAlt)
letFloatAltM w fvs (con, vs, Let bnds body) = do
let bSet = mkVarSet (bindVars bnds)
vSet = mkVarSet (w:vs)
guardMsg (not (w `elemVarSet` bSet)) "floating would allow case binder to capture variables."
guardMsg (isEmptyVarSet $ vSet `intersectVarSet` freeVarsBind bnds)
"floating would cause variables in rhs to become unbound."
guardMsg (isEmptyVarSet $ bSet `intersectVarSet` fvs)
"floating would cause let binders to capture variables in case expression."
return (bnds, (con, vs, body))
letFloatAltM _ _ _ = fail "no let expression on alternative right-hand side."
Case e w ty alts <- idR
fvs <- arr freeVarsExpr
let l = length alts 1
case maybeN of
Just n | n < 0 || n > l -> fail $ "valid alternative indices: 0 to " ++ show l
| otherwise -> do
let (pre, alt:suf) = splitAt n alts
(bnds,alt') <- letFloatAltM w fvs alt
return $ Let bnds $ Case e w ty $ pre ++ (alt':suf)
Nothing -> do
(bnds,alts') <- letFloatOneAltM w fvs alts
return $ Let bnds $ Case e w ty alts'
letFloatCastR :: MonadCatch m => Rewrite c m CoreExpr
letFloatCastR = prefixFailMsg "Let floating from Cast failed: " $
withPatFailMsg (wrongExprForm "Cast (Let bnds e) co") $
do Cast (Let bnds e) co <- idR
return $ Let bnds (Cast e co)
letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatExprR = setFailMsg "Unsuitable expression for Let floating."
$ letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR
<+ letFloatCaseR <+ letFloatCaseAltR Nothing <+ letFloatCastR
letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreProg
letFloatTopR = prefixFailMsg "Let floating to top level failed: " $
withPatFailMsg (wrongExprForm "NonRec v (Let bds e) `ProgCons` p") $
do ProgCons (NonRec v (Let bds e)) p <- idR
let bs = bindVars bds
guardMsg (all isId bs) "type and coercion bindings are not allowed at the top level."
let vs = intersectVarSet (mkVarSet bs) (freeVarsProg p)
if isEmptyVarSet vs
then return $ ProgCons bds (ProgCons (NonRec v e) p)
else consNonRecAllR idR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatTopR
letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatInR = letFloatInCaseR <+ letFloatInAppR <+ letFloatInLamR
letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatInCaseR = prefixFailMsg "Let floating in to case failed: " $
withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $
do Let bnds (Case s w ty alts) <- idR
let bs = bindVars bnds
captured = bs `intersect` (w : concatMap altVars alts)
guardMsg (null captured) "let bindings would capture case pattern bindings."
let unbound = mkVarSet bs `intersectVarSet` (tyVarsOfType ty `unionVarSet` freeVarsVar w)
guardMsg (isEmptyVarSet unbound) "type variables in case signature would become unbound."
return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR))
letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m, MonadUnique m)
=> Rewrite c m CoreExpr
letFloatInAppR = prefixFailMsg "Let floating in to app failed: " $
withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $
do Let bnds (App e1 e2) <- idR
lhs <- return (Let bnds e1) >>> alphaLetR
return $ App lhs (Let bnds e2)
letFloatInLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr
letFloatInLamR = prefixFailMsg "Let floating in to lambda failed: " $
withPatFailMsg (wrongExprForm "Let bnds (Lam v e)") $
do Let bnds (Lam v e) <- idR
safe <- letT (arr bindVars) lamVarT $ flip notElem
guardMsg safe "let bindings would capture lambda binding."
return $ Lam v $ Let bnds e
reorderNonRecLetsR :: MonadCatch m => [String] -> Rewrite c m CoreExpr
reorderNonRecLetsR nms = prefixFailMsg "Reorder lets failed: " $
do guardMsg (notNull nms) "no names given."
guardMsg (nodups nms) "duplicate names given."
e <- idR
(ves,x) <- setFailMsg "insufficient non-recursive lets." $ takeNonRecLets (length nms) e
guardMsg (noneFreeIn ves) "some of the bound variables appear in the right-hand-sides."
e' <- mkNonRecLets `liftM` mapM (lookupName ves) nms `ap` return x
guardMsg (not $ exprSyntaxEq e e') "bindings already in specified order."
return e'
where
takeNonRecLets :: Monad m => Int -> CoreExpr -> m ([(Var,CoreExpr)],CoreExpr)
takeNonRecLets 0 x = return ([],x)
takeNonRecLets n (Let (NonRec v1 e1) x) = first ((v1,e1):) `liftM` takeNonRecLets (n1) x
takeNonRecLets _ _ = fail "insufficient non-recursive lets."
noneFreeIn :: [(Var,CoreExpr)] -> Bool
noneFreeIn ves = let (vs,es) = unzip ves
in all (`notElemVarSet` unionVarSets (map freeVarsExpr es)) vs
lookupName :: Monad m => [(Var,CoreExpr)] -> String -> m (Var,CoreExpr)
lookupName ves nm = case filter (cmpString2Var nm . fst) ves of
[] -> fail $ "name " ++ nm ++ " not matched."
[ve] -> return ve
_ -> fail $ "multiple matches for " ++ nm ++ "."
mkNonRecLets :: [(Var,CoreExpr)] -> CoreExpr -> CoreExpr
mkNonRecLets [] x = x
mkNonRecLets ((v,e):ves) x = Let (NonRec v e) (mkNonRecLets ves x)
letTupleR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr
letTupleR nm = prefixFailMsg "Let-tuple failed: " $
do (bnds, body) <- arr collectLets
let numBnds = length bnds
guardMsg (numBnds > 1) "at least two non-recursive let bindings of identifiers required."
let (vs, rhss) = unzip bnds
let frees = map freeVarsExpr (drop 1 rhss)
used = unionVarSets $ zipWith intersectVarSet (map (mkVarSet . (`take` vs)) [1..]) frees
if isEmptyVarSet used
then let rhs = mkCoreTup rhss
in constT $ do bndr <- newIdH nm (exprType rhs)
return $ mkSmallTupleCase vs body bndr rhs
else fail $ "the following bound variables are used in subsequent bindings: " ++ showVarSet used
where
collectLets :: CoreExpr -> ([(Id, CoreExpr)],CoreExpr)
collectLets (Let (NonRec v e) body) | isId v = first ((v,e):) (collectLets body)
collectLets expr = ([],expr)
letIntroR :: (MonadCatch m, MonadUnique m) => String -> Rewrite c m CoreExpr
letIntroR nm = do e <- idR
Let (NonRec v e') _ <- letNonRecIntroR nm e
return $ Let (NonRec v e') (varToCoreExpr v)
letNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreExpr
letNonRecIntroR nm e = prefixFailMsg "Let-introduction failed: " $
contextfreeT $ \ body -> do v <- newVarH nm $ exprKindOrType e
return $ Let (NonRec v e) body
progNonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m CoreProg
progNonRecIntroR nm e = prefixFailMsg "Top-level binding introduction failed: " $
do guardMsg (not $ isTyCoArg e) "Top-level type or coercion definitions are prohibited."
contextfreeT $ \ prog -> do i <- newIdH nm (exprType e)
return $ ProgCons (NonRec i e) prog
nonRecIntroR :: (MonadCatch m, MonadUnique m) => String -> CoreExpr -> Rewrite c m Core
nonRecIntroR nm e = readerT $ \case
ExprCore{} -> promoteExprR (letNonRecIntroR nm e)
ProgCore{} -> promoteProgR (progNonRecIntroR nm e)
_ -> fail "can only introduce non-recursive bindings at Program or Expression nodes."
letIntroUnfoldingR :: ( BoundVars c, ReadBindings c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m
, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
=> HermitName -> Rewrite c m CoreExpr
letIntroUnfoldingR nm = do
i <- findIdT nm
(rhs,_) <- getUnfoldingT AllBinders <<< return i
contextfreeT $ \ body -> do
i' <- cloneVarH id i
let subst = substCoreExpr i (varToCoreExpr i')
bnd = if i `elemUFM` freeVarsExpr rhs then Rec [(i', subst rhs)]
else NonRec i' rhs
body' = subst body
return $ mkCoreLet bnd body'