clash-lib-1.8.2: src/Clash/Normalize/Transformations/Inline.hs
{-|
Copyright : (C) 2012-2016, University of Twente,
2016-2017, Myrtle Software Ltd,
2017-2022, Google Inc.,
2021-2024, QBayLogic B.V.
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Transformations for inlining
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.Normalize.Transformations.Inline
( bindConstantVar
, inlineBndrsCleanup
, inlineCast
, inlineCleanup
, collapseRHSNoops
, inlineNonRep
, inlineOrLiftNonRep
, inlineSimIO
, inlineSmall
, inlineWorkFree
) where
import qualified Control.Lens as Lens
import qualified Control.Monad as Monad
import Control.Monad ((>=>))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Writer (lift,listen)
import Data.Default (Default(..))
import Data.Either (lefts)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Monoid as Monoid (Any(..))
import qualified Data.Text as Text
import qualified Data.Text.Extra as Text
import GHC.Stack (HasCallStack)
import GHC.BasicTypes.Extra (isNoInline)
import qualified Clash.Explicit.SimIO as SimIO
import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV), xToBV)
import Clash.Annotations.Primitive (extractPrim)
import Clash.Core.DataCon (DataCon(..))
import Clash.Core.FreeVars
(countFreeOccurances, freeLocalIds)
import Clash.Core.HasFreeVars
import Clash.Core.HasType
import Clash.Core.Name (Name(..), NameSort(..))
import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr')
import Clash.Core.Subst
import Clash.Core.Term
( CoreContext(..), Pat(..), PrimInfo(..), Term(..), WorkInfo(..), collectArgs
, collectArgsTicks, mkApps , mkTicks, stripTicks)
import Clash.Core.TermInfo (isLocalVar, termSize)
import Clash.Core.Type
(TypeView(..), isClassTy, isPolyFunCoreTy, tyView)
import Clash.Core.Util (isSignalType, primUCo)
import Clash.Core.Var (Id, Var(..), isGlobalId, isLocalId)
import Clash.Core.VarEnv
( InScopeSet, VarEnv, VarSet, elemUniqInScopeSet, elemVarEnv, elemVarSet
, eltsVarEnv, emptyVarEnv, extendInScopeSetList, extendVarEnv
, foldlWithUniqueVarEnv', lookupVarEnv, lookupVarEnvDirectly, mkVarEnv
, notElemVarSet, unionVarEnv, unionVarEnvWith, unitVarSet)
import Clash.Debug (trace)
import Clash.Driver.Types (Binding(..))
import Clash.Netlist.Util (representableType)
import Clash.Primitives.Types
(CompiledPrimMap, Primitive(..), TemplateKind(..))
import Clash.Rewrite.Combinators (allR)
import Clash.Rewrite.Types
( TransformContext(..), bindings, curFun, customReprs, tcCache, topEntities
, typeTranslator, inlineConstantLimit, inlineFunctionLimit, inlineLimit
, inlineWFCacheLimit, primitives)
import Clash.Rewrite.Util
( changed, inlineBinders, inlineOrLiftBinders, isJoinPointIn
, isUntranslatable, isUntranslatableType, isVoidWrapper, zoomExtra)
import Clash.Rewrite.WorkFree (isWorkFreeIsh)
import Clash.Normalize.Types ( NormRewrite, NormalizeSession)
import Clash.Normalize.Util
( addNewInline, alreadyInlined, isRecursiveBndr, mkInlineTick
, normalizeTopLvlBndr)
import Clash.Unique (Unique)
import Clash.Util (curLoc)
import qualified Clash.Util.Interpolate as I
{- [Note] join points and void wrappers
Join points are functions that only occur in tail-call positions within an
expression, and only when they occur in a tail-call position more than once.
Normally bindNonRep binds/inlines all non-recursive local functions. However,
doing so for join points would significantly increase compilation time, so we
avoid it. The only exception to this rule are so-called void wrappers. Void
wrappers are functions of the form:
> \(w :: Void) -> f a b c
i.e. a wrapper around the function 'f' where the argument 'w' is not used. We
do bind/line these join-points because these void-wrappers interfere with the
'disjoint expression consolidation' (DEC) and 'common sub-expression elimination'
(CSE) transformation, sometimes resulting in circuits that are twice as big
as they'd need to be.
-}
-- | Inline let-bindings when the RHS is either a local variable reference or
-- is constant (except clock or reset generators)
bindConstantVar :: HasCallStack => NormRewrite
bindConstantVar = inlineBinders test
where
test _ (i,stripTicks -> e) = case isLocalVar e of
-- Don't inline `let x = x in x`, it throws us in an infinite loop
True -> return (i `notElemFreeVars` e)
_ -> do
tcm <- Lens.view tcCache
(fn,_) <- Lens.use curFun
-- Don't inline things that perform work, it increases the circuit size.
--
-- Also don't inline globally recursive calls, it prevents the
-- recToLetRec transformation from transforming global recursion to
-- local recursion.
-- See https://github.com/clash-lang/clash-compiler/issues/2839
case isWorkFreeIsh tcm e && not (e == Var fn) of
True -> Lens.view inlineConstantLimit >>= \case
0 -> return True
n -> return (termSize e <= n)
_ -> return False
{-# SCC bindConstantVar #-}
-- | Mark to track progress of 'reduceBindersCleanup'
data Mark = Temp | Done | Rec
-- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into
-- the other to-inline let-binders.
reduceBindersCleanup
:: HasCallStack
=> InScopeSet
-- ^ Current InScopeSet
-> VarEnv ((Id,Term),VarEnv Int)
-- ^ Original let-binders with their free variables (+ #occurrences)
-> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))
-- ^ Accumulated:
--
-- 1. (Maybe) the build up substitution so far
-- 2. The free variables of the range of the substitution
-- 3. Processed let-binders with their free variables and a tag to mark
-- the progress:
-- * Temp: Will eventually form a recursive cycle
-- * Done: Processed, non-recursive
-- * Rec: Processed, recursive
-> Unique
-- ^ The unique of the let-binding that we want to simplify
-> Int
-- ^ Ignore, artifact of 'foldlWithUniqueVarEnv'
-> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))
-- ^ Same as the third argument
reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ =
case lookupVarEnvDirectly u doneInl of
Nothing -> case lookupVarEnvDirectly u origInl of
Nothing ->
-- let-binding not found, cannot extend the substitution
if elemUniqInScopeSet u isN then
(substM,substFVs,doneInl)
else
error [I.i|
Internal error: 'reduceBindersCleanup' encountered a variable
reference that was neither in 'doneInl', 'origInl', or in the
transformation's in scope set. Unique was: '#{u}'.
|]
Just ((v,e),eFVs) ->
-- Simplify the transitive dependencies
let (sM,substFVsE,doneInl1) =
foldlWithUniqueVarEnv'
(reduceBindersCleanup isN origInl)
( Nothing
-- It's okay/needed to over-approximate the free variables of
-- the range of the new substitution by including the free
-- variables of the original let-binder, because this set of
-- free variables is only used to check whether let-binding will
-- become self-recursive after applying the substitution.
--
-- That is, it was already self-recursive, or becomes
-- self-recursive after applying the substitution because it was
-- part of a recursive group. And we do not want to inline
-- recursive binders.
, eFVs
-- Temporarily extend the processing environment with the
-- let-binding so we don't end up in a loop in case there is a
-- recursive group.
, extendVarEnv v ((v,e),eFVs,Temp) doneInl)
eFVs
e1 = maybeSubstTm "reduceBindersCleanup" sM e
in if v `elemVarEnv` substFVsE then
-- We cannot inline recursive let-bindings, so we do not extend
-- the substitution environment.
( substM
, substFVs
-- And we explicitly mark the let-binding as recursive in the
-- processing environment. So that it will be kept around at the
-- end of 'inlineCleanup'
, extendVarEnv v ((v,e1),substFVsE,Rec) doneInl1
)
else
-- Extend the substitution
( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e1)
, unionVarEnv substFVsE substFVs
-- Mark the let-binding a fully "reduced", so we don't repeat
-- this process when we encounter it again.
, extendVarEnv v ((v,e1),substFVsE,Done) doneInl1
)
-- It's already been processed, just extend the substitution environment
Just ((v,e),eFVs,Done) ->
( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e)
, unionVarEnv eFVs substFVs
, doneInl
)
-- It's either recursive (Rec), or part of a recursive group (Temp) where we
-- originally entered a different part of the cycle. Regardless, we do not
-- extend the substitution environment.
Just _ ->
( substM
, substFVs
, doneInl
)
{-# SCC reduceBindersCleanup #-}
-- | Used by 'inlineCleanup' to inline binders that we want to inline into the
-- binders that we want to keep.
inlineBndrsCleanup
:: HasCallStack
=> InScopeSet
-- ^ Current InScopeSet
-> VarEnv ((Id,Term),VarEnv Int)
-- ^ Original let-binders with their free variables (+ #occurrences), that we
-- want to inline
-> VarEnv ((Id,Term),VarEnv Int,Mark)
-- ^ Processed let-binders with their free variables and a tag to mark the
-- progress:
-- * Temp: Will eventually form a recursive cycle
-- * Done: Processed, non-recursive
-- * Rec: Processed, recursive
-> [((Id,Term),VarEnv Int)]
-- ^ The let-binders with their free variables (+ #occurrences), that we want
-- to keep
-> [(Id,Term)]
inlineBndrsCleanup isN origInl = go
where
go doneInl [] =
-- If some of the let-binders that we wanted to inline turn out to be
-- recursive, then we have to keep those around as well, as we weren't able
-- to inline them. Furthermore, for every recursive binder there might still
-- be non-inlined variables left, see #1337.
flip map [ (ve, eFvs) | (ve,eFvs,Rec) <- eltsVarEnv doneInl ] $ \((v, e), eFvs) ->
let
(substM, _, _) = foldlWithUniqueVarEnv'
(reduceBindersCleanup isN emptyVarEnv)
(Nothing, emptyVarEnv, doneInl)
eFvs
in (v, maybeSubstTm "inlineBndrsCleanup_0" substM e)
go !doneInl_0 (((v,e),eFVs):il) =
let (sM,_,doneInl_1) = foldlWithUniqueVarEnv'
(reduceBindersCleanup isN origInl)
(Nothing, emptyVarEnv, doneInl_0)
eFVs
e1 = maybeSubstTm "inlineBndrsCleanup_1" sM e
in (v,e1):go doneInl_1 il
{-# SCC inlineBndrsCleanup #-}
-- | Only inline casts that just contain a 'Var', because these are guaranteed work-free.
-- These are the result of the 'splitCastWork' transformation.
inlineCast :: HasCallStack => NormRewrite
inlineCast = inlineBinders test
where
test _ (_, (Cast (stripTicks -> Var {}) _ _)) = return True
test _ _ = return False
{-# SCC inlineCast #-}
-- | Given a function in the desired normal form, inline all the following
-- let-bindings:
--
-- Let-bindings with an internal name that is only used once, where it binds:
-- * a primitive that will be translated to an HDL expression (as opposed to
-- a HDL declaration)
-- * a projection case-expression (1 alternative)
-- * a data constructor
-- * I/O actions
inlineCleanup :: HasCallStack => NormRewrite
inlineCleanup (TransformContext is0 _) (Letrec binds body) = do
prims <- Lens.view primitives
-- For all let-bindings, count the number of times they are referenced.
-- We only inline let-bindings which are referenced only once, otherwise
-- we would lose sharing.
let is1 = extendInScopeSetList is0 (map fst binds)
bindsFvs = map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds
allOccs = List.foldl' (unionVarEnvWith (+)) emptyVarEnv
$ map (snd.snd) bindsFvs
bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body
(il,keep) = List.partition (isInteresting allOccs prims bodyFVs)
bindsFvs
keep' = inlineBndrsCleanup is1 (mkVarEnv il) emptyVarEnv
$ map snd keep
if | null il -> return (Letrec binds body)
| null keep' -> changed body
| otherwise -> changed (Letrec keep' body)
where
-- Determine whether a let-binding is interesting to inline
isInteresting
:: VarEnv Int
-> CompiledPrimMap
-> VarSet
-> (Id,((Id, Term), VarEnv Int))
-> Bool
isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_))
-- Try to keep user defined names, but inline names generated by GHC or
-- Clash. For example, if a user were to write:
--
-- x = 2 * y
--
-- Even if 'x' is only used once, we'd like to keep it around to produce
-- more readable HDL. In contrast, if a user were to write:
--
-- let x = f (2 * y)
--
-- ANF would transform that to:
--
-- let x = f f_arg; f_arg = 2 * y
--
-- In that case, there's no harm in inlining f_arg.
| nameSort (varName id_) /= User
, id_ `notElemVarSet` bodyFVs
= case tm of
Prim pInfo
| let nm = primName pInfo
, Just (extractPrim -> Just p@(BlackBox {})) <- HashMap.lookup nm prims
, TExpr <- kind p
, Just occ <- lookupVarEnv id_ allOccs
, occ < 2
-> True
| otherwise
-> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"]
Case _ _ [_] -> True
Data _ -> True
Case _ aTy (_:_:_)
| TyConApp nm _ <- tyView aTy
, nameOcc nm == Text.showt ''SimIO.SimIO
-> True
_ -> False
| id_ `notElemVarSet` bodyFVs
= case tm of
Prim pInfo
| primName pInfo `elem`
[ Text.showt 'SimIO.openFile
, Text.showt 'SimIO.getChar
, Text.showt 'SimIO.isEOF
]
, Just occ <- lookupVarEnv id_ allOccs
, occ < 2
-> True
| otherwise
-> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"]
Case _ _ [(DataPat dcE _ _,_)]
-> let nm = (nameOcc (dcName dcE))
in -- Inlines WW projection that exposes internals of the BitVector types
nm == Text.showt 'BV.BV ||
nm == Text.showt 'BV.Bit ||
-- Inlines projections out of constraint-tuples (e.g. HiddenClockReset)
"GHC.Classes" `Text.isPrefixOf` nm
Case _ aTy (_:_:_)
| TyConApp nm _ <- tyView aTy
, nameOcc nm == Text.showt ''SimIO.SimIO
-> True
_ -> False
isInteresting _ _ _ _ = False
inlineCleanup _ e = return e
{-# SCC inlineCleanup #-}
{- [Note] relation `collapseRHSNoops` and `inlineCleanup`
The `collapseRHSNoops` transformation replaces functions/primitives that are the identity
in HDL, but not in Haskell, by `unsafeCoerce`.
`inlineCleanup` subsequently inlines these `unsafeCoerce` calls.
The end result of all of this is that we get no/fewer assignments in HDL where the RHS is
simply a variable reference. See issue #779 -}
-- | Takes a binding and collapses its term if it is a noop
collapseRHSNoops :: HasCallStack => NormRewrite
collapseRHSNoops _ (Letrec binds body) = do
binds1 <- mapM runCollapseNoop binds
return $ Letrec binds1 body
where
runCollapseNoop orig =
runMaybeT (collapseNoop orig) >>= Maybe.maybe (return orig) changed
collapseNoop (iD,term) = do
(Prim info,args) <- return $ collectArgs term
identity <- getIdentity info $ lefts args
collapsed <- collapseToIdentity iD identity
return (iD,collapsed)
collapseToIdentity iD identity = do
tcm <- Lens.view tcCache
let aTy = inferCoreTypeOf tcm identity
bTy = coreTypeOf iD
return $ primUCo `TyApp` aTy `TyApp` bTy `App` identity
getIdentity primInfo termArgs = do
WorkIdentity idIdx noopIdxs <- return $ primWorkInfo primInfo
mapM_ (getTermArg termArgs >=> isNoop >=> Monad.guard) noopIdxs
getTermArg termArgs idIdx
getTermArg args i = do
Monad.guard $ i <= length args - 1
return $ args !! i
isNoop (Var i) = do
binding <- MaybeT $ lookupVarEnv i <$> Lens.use bindings
isRecursive <- lift $ isRecursiveBndr $ bindingId binding
Monad.guard $ not isRecursive
isNoop $ bindingTerm binding
isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True
isNoop (Lam x e) = isNoopApp x (collectArgs e)
isNoop _ = return False
-- Check whether we have a term of the form:
--
-- primX a (primY b (primZ c (... x ...))))
--
-- Where primX, primY and primZ are either:
--
-- 1. xToBV, or
-- 2. Primitives that are the identity on their argument
--
-- And that the variable 'x' is used by the last primitive in the chain.
isNoopApp x (Var y,[]) = return (x == y)
isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do
arg <- getTermArg (lefts args) i
isNoopApp x (collectArgs arg)
isNoopApp x (Prim PrimInfo{primName},args)
| primName == Text.showt 'BV.xToBV = do
-- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't
-- want 'getIdentity' to replace "naked" occurances of 'xToBV' by
-- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator
-- rule that can translate XExceptions to 'undefined# :: BitVector n'.
arg@(App {}) <- getTermArg (lefts args) 1
isNoopApp x (collectArgs arg)
isNoopApp _ _ = return False
collapseRHSNoops _ e = return e
{-# SCC collapseRHSNoops #-}
-- | Inline function with a non-representable result if it's the subject
-- of a Case-decomposition. It's a custom topdown traversal that -for efficiency
-- reasons- does not explore alternative of cases whose subject triggered an
-- 'inlineNonRepWorker'.
inlineNonRep :: HasCallStack => NormRewrite
inlineNonRep ctx0 e0@(Case {}) = do
r <- listen (inlineNonRepWorker e0)
case r of
(e1, Monoid.getAny -> True) ->
return e1
(e1, _) -> do
-- If a term _in_ the subject triggers 'inlineNonRepWorker', inline and
-- propagate might eliminate this case. We therefore don't explore the
-- alternatives. Note that this makes it substantially different from a
-- 'topdownSucR' transformation.
let
(subj0,typ,alts) = case e1 of
Case s t a -> (s,t,a)
_ -> error ("internal error, inlineNonRep triggered on a non-Case:" <>
showPpr e1)
TransformContext inScope ctx1 = ctx0
ctx2 = TransformContext inScope (CaseScrut:ctx1)
listen (inlineNonRep ctx2 subj0) >>= \case
(subj1, Monoid.getAny -> True) ->
return (Case subj1 typ alts)
(subj1, _) -> do
let (pats, rhss0) = unzip alts
rhss1 <- mapM (inlineNonRep ctx2) rhss0
pure (Case subj1 typ (zip pats rhss1))
inlineNonRep ctx e =
-- All non-case statements are simply traversed. TODO: are there other special
-- cases like 'Case' that would warrant an optimization like ^ ?
allR inlineNonRep ctx e
{-# SCC inlineNonRep #-}
-- | Inline function with a non-representable result if it's the subject
-- of a Case-decomposition. This worker function only tries the given term
-- (i.e., it does not traverse it).
--
-- It sets the changed flag in the NormalizeSession if it successfully inlines
-- a binder.
inlineNonRepWorker :: HasCallStack => Term -> NormalizeSession Term
inlineNonRepWorker e@(Case scrut altsTy alts)
| (Var f, args,ticks) <- collectArgsTicks scrut
, isGlobalId f
= do
(cf,_) <- Lens.use curFun
isInlined <- zoomExtra (alreadyInlined f cf)
limit <- Lens.view inlineLimit
tcm <- Lens.view tcCache
let
scrutTy = inferCoreTypeOf tcm scrut
-- Constraint dictionary inlining always terminates, so we ignore the
-- usual inline safeguards.
notClassTy = not (isClassTy tcm scrutTy)
overLimit = notClassTy && (Maybe.fromMaybe 0 isInlined) > limit
bodyMaybe <- lookupVarEnv f <$> Lens.use bindings
nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator
<*> Lens.view customReprs
<*> pure False
<*> Lens.view tcCache
<*> pure scrutTy)
case (nonRepScrut, bodyMaybe) of
(True, Just b) -> do
if overLimit then
trace ($(curLoc) ++ [I.i|
InlineNonRep: #{showPpr (varName f)} already inlined
#{limit} times in: #{showPpr (varName cf)}. The type of the subject
is:
#{showPpr' def{displayTypes=True\} scrutTy}
Function #{showPpr (varName cf)} will not reach a normal form and
compilation might fail.
Run with '-fclash-inline-limit=N' to increase the inline limit to N.
|]) (return e)
else do
Monad.when notClassTy (zoomExtra (addNewInline f cf))
let scrutBody0 = mkTicks (bindingTerm b) (mkInlineTick f : ticks)
let scrutBody1 = mkApps scrutBody0 args
changed $ Case scrutBody1 altsTy alts
_ ->
return e
inlineNonRepWorker e = pure e
{-# SCC inlineNonRepWorker #-}
inlineOrLiftNonRep :: HasCallStack => NormRewrite
inlineOrLiftNonRep ctx eLet@(Letrec _ body) =
inlineOrLiftBinders nonRepTest inlineTest ctx eLet
where
bodyFreeOccs = countFreeOccurances body
nonRepTest :: (Id, Term) -> NormalizeSession Bool
nonRepTest (Id {varType = ty}, _)
= not <$> (representableType <$> Lens.view typeTranslator
<*> Lens.view customReprs
<*> pure False
<*> Lens.view tcCache
<*> pure ty)
nonRepTest _ = return False
inlineTest :: Term -> (Id, Term) -> Bool
inlineTest e (id_, e') =
-- We do __NOT__ inline:
not $ or
[ -- 1. recursive let-binders
-- id_ `elemFreeVars` e' -- <= already checked in inlineOrLiftBinders
-- 2. join points (which are not void-wrappers)
isJoinPointIn id_ e && not (isVoidWrapper e')
-- 3. binders that are used more than once in the body, because
-- it makes CSE a whole lot more difficult.
--
-- XXX: Check whether we can extend this to the binders as well
, maybe False (>1) (lookupVarEnv id_ bodyFreeOccs)
]
inlineOrLiftNonRep _ e = return e
{-# SCC inlineOrLiftNonRep #-}
-- | Inline anything of type `SimIO`: IO actions cannot be shared
inlineSimIO :: HasCallStack => NormRewrite
inlineSimIO = inlineBinders test
where
test _ (i,_) = case tyView (coreTypeOf i) of
TyConApp tc _ -> return $! nameOcc tc == Text.showt ''SimIO.SimIO
_ -> return False
{-# SCC inlineSimIO #-}
-- | Inline small functions
inlineSmall :: HasCallStack => NormRewrite
inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) = do
untranslatable <- isUntranslatable True e
topEnts <- Lens.view topEntities
let lv = isLocalId f
if untranslatable || f `elemVarSet` topEnts || lv
then return e
else do
bndrs <- Lens.use bindings
sizeLimit <- Lens.view inlineFunctionLimit
case lookupVarEnv f bndrs of
-- Don't inline recursive expressions
Just b -> do
isRecBndr <- isRecursiveBndr f
if not isRecBndr && not (isNoInline (bindingSpec b)) && termSize (bindingTerm b) < sizeLimit
then do
let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks)
changed $ mkApps tm args
else return e
_ -> return e
inlineSmall _ e = return e
{-# SCC inlineSmall #-}
-- | Inline work-free functions, i.e. fully applied functions that evaluate to
-- a constant
inlineWorkFree :: HasCallStack => NormRewrite
inlineWorkFree _ e@(collectArgsTicks -> (Var f,args@(_:_),ticks))
= do
tcm <- Lens.view tcCache
let eTy = inferCoreTypeOf tcm e
argsHaveWork <- or <$> mapM (either expressionHasWork
(const (pure False)))
args
untranslatable <- isUntranslatableType True eTy
topEnts <- Lens.view topEntities
let isSignal = isSignalType tcm eTy
let lv = isLocalId f
let isTopEnt = elemVarSet f topEnts
if untranslatable || isSignal || argsHaveWork || lv || isTopEnt
then return e
else do
bndrs <- Lens.use bindings
case lookupVarEnv f bndrs of
-- Don't inline recursive expressions
Just b -> do
isRecBndr <- isRecursiveBndr f
if isRecBndr
then return e
else do
let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks)
changed $ mkApps tm args
_ -> return e
where
-- an expression is has work when it contains free local variables,
-- or has a Signal type, i.e. it does not evaluate to a work-free
-- constant.
expressionHasWork e' = do
let fvIds = Lens.toListOf freeLocalIds e'
tcm <- Lens.view tcCache
let e'Ty = inferCoreTypeOf tcm e'
isSignal = isSignalType tcm e'Ty
return (not (null fvIds) || isSignal)
inlineWorkFree _ e@(Var f) = do
tcm <- Lens.view tcCache
let fTy = coreTypeOf f
closed = not (isPolyFunCoreTy tcm fTy)
isSignal = isSignalType tcm fTy
untranslatable <- isUntranslatableType True fTy
topEnts <- Lens.view topEntities
let gv = isGlobalId f
if closed && f `notElemVarSet` topEnts && not untranslatable && not isSignal && gv
then do
bndrs <- Lens.use bindings
case lookupVarEnv f bndrs of
-- Don't inline recursive expressions
Just top -> do
isRecBndr <- isRecursiveBndr f
if isRecBndr
then return e
else do
let topB = bindingTerm top
sizeLimit <- Lens.view inlineWFCacheLimit
-- caching only worth it from a certain size onwards, otherwise
-- the caching mechanism itself brings more of an overhead.
if termSize topB < sizeLimit then
changed topB
else do
b <- normalizeTopLvlBndr False f top
changed (bindingTerm b)
_ -> return e
else return e
inlineWorkFree _ e = return e
{-# SCC inlineWorkFree #-}