{-|
  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 qualified Clash.Core.Term as Term
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 :: HasCallStack => NormRewrite
bindConstantVar = (Term -> LetBinding -> RewriteMonad NormalizeState Bool)
-> NormRewrite
forall extra.
(Term -> LetBinding -> RewriteMonad extra Bool) -> Rewrite extra
inlineBinders Term -> LetBinding -> RewriteMonad NormalizeState Bool
forall {m :: Type -> Type} {extra} {p}.
(MonadReader RewriteEnv m, MonadState (RewriteState extra) m) =>
p -> LetBinding -> m Bool
test
  where
    test :: p -> LetBinding -> m Bool
test p
_ (Id
i,Term -> Term
stripTicks -> Term
e) = case Term -> Bool
isLocalVar Term
e of
      -- Don't inline `let x = x in x`, it throws  us in an infinite loop
      Bool
True -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
i Id -> Term -> Bool
forall a. HasFreeVars a => Var a -> a -> Bool
`notElemFreeVars` Term
e)
      Bool
_    -> do
        tcm <- Getting TyConMap RewriteEnv TyConMap -> m TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
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
          Bool
True -> Getting Word RewriteEnv Word -> m Word
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Word RewriteEnv Word
Getter RewriteEnv Word
inlineConstantLimit m Word -> (Word -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Word
0 -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
            Word
n -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Word
termSize Term
e Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
n)
          Bool
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
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 :: HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
reduceBindersCleanup InScopeSet
isN VarEnv (LetBinding, VarEnv Int)
origInl (!Maybe Subst
substM,!VarEnv Int
substFVs,!VarEnv (LetBinding, VarEnv Int, Mark)
doneInl) Unique
u Int
_ =
  case Unique
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> Maybe (LetBinding, VarEnv Int, Mark)
forall a. Unique -> VarEnv a -> Maybe a
lookupVarEnvDirectly Unique
u VarEnv (LetBinding, VarEnv Int, Mark)
doneInl of
    Maybe (LetBinding, VarEnv Int, Mark)
Nothing -> case Unique
-> VarEnv (LetBinding, VarEnv Int)
-> Maybe (LetBinding, VarEnv Int)
forall a. Unique -> VarEnv a -> Maybe a
lookupVarEnvDirectly Unique
u VarEnv (LetBinding, VarEnv Int)
origInl of
      Maybe (LetBinding, VarEnv Int)
Nothing ->
        -- let-binding not found, cannot extend the substitution
        if Unique -> InScopeSet -> Bool
elemUniqInScopeSet Unique
u InScopeSet
isN then
          (Maybe Subst
substM,VarEnv Int
substFVs,VarEnv (LetBinding, VarEnv Int, Mark)
doneInl)
        else
          [Char]
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
forall a. HasCallStack => [Char] -> a
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 ((Id
v,Term
e),VarEnv Int
eFVs) ->
        -- Simplify the transitive dependencies
        let (Maybe Subst
sM,VarEnv Int
substFVsE,VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1) =
              ((Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
 -> Unique
 -> Int
 -> (Maybe Subst, VarEnv Int,
     VarEnv (LetBinding, VarEnv Int, Mark)))
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> VarEnv Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
forall a b. (a -> Unique -> b -> a) -> a -> VarEnv b -> a
foldlWithUniqueVarEnv'
                (HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
reduceBindersCleanup InScopeSet
isN VarEnv (LetBinding, VarEnv Int)
origInl)
                ( Maybe Subst
forall a. Maybe a
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.
                , VarEnv Int
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.
                , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e),VarEnv Int
eFVs,Mark
Temp) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl)
                VarEnv Int
eFVs

            e1 :: Term
e1 = HasCallStack => Doc () -> Maybe Subst -> Term -> Term
Doc () -> Maybe Subst -> Term -> Term
maybeSubstTm Doc ()
"reduceBindersCleanup" Maybe Subst
sM Term
e
        in  if Id
v Id -> VarEnv Int -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` VarEnv Int
substFVsE then
              -- We cannot inline recursive let-bindings, so we do not extend
              -- the substitution environment.
              ( Maybe Subst
substM
              , VarEnv Int
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'
              , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e1),VarEnv Int
substFVsE,Mark
Rec) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1
              )
            else
              -- Extend the substitution
              ( Subst -> Maybe Subst
forall a. a -> Maybe a
Just (Subst -> Id -> Term -> Subst
extendIdSubst (Subst -> Maybe Subst -> Subst
forall a. a -> Maybe a -> a
Maybe.fromMaybe (InScopeSet -> Subst
mkSubst InScopeSet
isN) Maybe Subst
substM) Id
v Term
e1)
              , VarEnv Int -> VarEnv Int -> VarEnv Int
forall a. VarEnv a -> VarEnv a -> VarEnv a
unionVarEnv VarEnv Int
substFVsE VarEnv Int
substFVs
              -- Mark the let-binding a fully "reduced", so we don't repeat
              -- this process when we encounter it again.
              , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e1),VarEnv Int
substFVsE,Mark
Done) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1
              )
    -- It's already been processed, just extend the substitution environment
    Just ((Id
v,Term
e),VarEnv Int
eFVs,Mark
Done) ->
      ( Subst -> Maybe Subst
forall a. a -> Maybe a
Just (Subst -> Id -> Term -> Subst
extendIdSubst (Subst -> Maybe Subst -> Subst
forall a. a -> Maybe a -> a
Maybe.fromMaybe (InScopeSet -> Subst
mkSubst InScopeSet
isN) Maybe Subst
substM) Id
v Term
e)
      , VarEnv Int -> VarEnv Int -> VarEnv Int
forall a. VarEnv a -> VarEnv a -> VarEnv a
unionVarEnv VarEnv Int
eFVs VarEnv Int
substFVs
      , VarEnv (LetBinding, VarEnv Int, Mark)
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 (LetBinding, VarEnv Int, Mark)
_ ->
      ( Maybe Subst
substM
      , VarEnv Int
substFVs
      , VarEnv (LetBinding, VarEnv Int, Mark)
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 :: HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)]
-> [LetBinding]
inlineBndrsCleanup InScopeSet
isN VarEnv (LetBinding, VarEnv Int)
origInl = VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
go
 where
  go :: VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
go VarEnv (LetBinding, VarEnv Int, Mark)
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.
    (((LetBinding, VarEnv Int) -> LetBinding)
 -> [(LetBinding, VarEnv Int)] -> [LetBinding])
-> [(LetBinding, VarEnv Int)]
-> ((LetBinding, VarEnv Int) -> LetBinding)
-> [LetBinding]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((LetBinding, VarEnv Int) -> LetBinding)
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map [ (LetBinding
ve, VarEnv Int
eFvs) | (LetBinding
ve,VarEnv Int
eFvs,Mark
Rec) <- VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int, Mark)]
forall a. VarEnv a -> [a]
eltsVarEnv VarEnv (LetBinding, VarEnv Int, Mark)
doneInl ] (((LetBinding, VarEnv Int) -> LetBinding) -> [LetBinding])
-> ((LetBinding, VarEnv Int) -> LetBinding) -> [LetBinding]
forall a b. (a -> b) -> a -> b
$ \((Id
v, Term
e), VarEnv Int
eFvs) ->
      let
        (Maybe Subst
substM, VarEnv Int
_, VarEnv (LetBinding, VarEnv Int, Mark)
_) = ((Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
 -> Unique
 -> Int
 -> (Maybe Subst, VarEnv Int,
     VarEnv (LetBinding, VarEnv Int, Mark)))
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> VarEnv Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
forall a b. (a -> Unique -> b -> a) -> a -> VarEnv b -> a
foldlWithUniqueVarEnv'
                           (HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
reduceBindersCleanup InScopeSet
isN VarEnv (LetBinding, VarEnv Int)
forall a. VarEnv a
emptyVarEnv)
                           (Maybe Subst
forall a. Maybe a
Nothing, VarEnv Int
forall a. VarEnv a
emptyVarEnv, VarEnv (LetBinding, VarEnv Int, Mark)
doneInl)
                           VarEnv Int
eFvs
      in (Id
v, HasCallStack => Doc () -> Maybe Subst -> Term -> Term
Doc () -> Maybe Subst -> Term -> Term
maybeSubstTm Doc ()
"inlineBndrsCleanup_0" Maybe Subst
substM Term
e)
  go !VarEnv (LetBinding, VarEnv Int, Mark)
doneInl_0 (((Id
v,Term
e),VarEnv Int
eFVs):[(LetBinding, VarEnv Int)]
il) =
    let (Maybe Subst
sM,VarEnv Int
_,VarEnv (LetBinding, VarEnv Int, Mark)
doneInl_1) = ((Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
 -> Unique
 -> Int
 -> (Maybe Subst, VarEnv Int,
     VarEnv (LetBinding, VarEnv Int, Mark)))
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> VarEnv Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
forall a b. (a -> Unique -> b -> a) -> a -> VarEnv b -> a
foldlWithUniqueVarEnv'
                            (HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
-> Unique
-> Int
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
reduceBindersCleanup InScopeSet
isN VarEnv (LetBinding, VarEnv Int)
origInl)
                            (Maybe Subst
forall a. Maybe a
Nothing, VarEnv Int
forall a. VarEnv a
emptyVarEnv, VarEnv (LetBinding, VarEnv Int, Mark)
doneInl_0)
                            VarEnv Int
eFVs
        e1 :: Term
e1 = HasCallStack => Doc () -> Maybe Subst -> Term -> Term
Doc () -> Maybe Subst -> Term -> Term
maybeSubstTm Doc ()
"inlineBndrsCleanup_1" Maybe Subst
sM Term
e
    in  (Id
v,Term
e1)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
go VarEnv (LetBinding, VarEnv Int, Mark)
doneInl_1 [(LetBinding, VarEnv Int)]
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 :: HasCallStack => NormRewrite
inlineCast = (Term -> LetBinding -> RewriteMonad NormalizeState Bool)
-> NormRewrite
forall extra.
(Term -> LetBinding -> RewriteMonad extra Bool) -> Rewrite extra
inlineBinders Term -> LetBinding -> RewriteMonad NormalizeState Bool
forall {m :: Type -> Type} {p} {a}.
Monad m =>
p -> (a, Term) -> m Bool
test
  where
    test :: p -> (a, Term) -> m Bool
test p
_ (a
_, (Cast (Term -> Term
stripTicks -> Var {}) Type
_ Type
_)) = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
    test p
_ (a, Term)
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
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 :: HasCallStack => NormRewrite
inlineCleanup (TransformContext InScopeSet
is0 Context
_) (Letrec [LetBinding]
binds Term
body) = do
  prims <- Getting CompiledPrimMap RewriteEnv CompiledPrimMap
-> RewriteMonad NormalizeState CompiledPrimMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CompiledPrimMap RewriteEnv CompiledPrimMap
Getter RewriteEnv CompiledPrimMap
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       = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
binds)
      bindsFvs  = (LetBinding -> (Id, (LetBinding, VarEnv Int)))
-> [LetBinding] -> [(Id, (LetBinding, VarEnv Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
v,Term
e) -> (Id
v,((Id
v,Term
e),Term -> VarEnv Int
countFreeOccurances Term
e))) [LetBinding]
binds
      allOccs   = (VarEnv Int -> VarEnv Int -> VarEnv Int)
-> VarEnv Int -> [VarEnv Int] -> VarEnv Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Int -> Int -> Int) -> VarEnv Int -> VarEnv Int -> VarEnv Int
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
unionVarEnvWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)) VarEnv Int
forall a. VarEnv a
emptyVarEnv
                ([VarEnv Int] -> VarEnv Int) -> [VarEnv Int] -> VarEnv Int
forall a b. (a -> b) -> a -> b
$ ((Id, (LetBinding, VarEnv Int)) -> VarEnv Int)
-> [(Id, (LetBinding, VarEnv Int))] -> [VarEnv Int]
forall a b. (a -> b) -> [a] -> [b]
map ((LetBinding, VarEnv Int) -> VarEnv Int
forall a b. (a, b) -> b
snd((LetBinding, VarEnv Int) -> VarEnv Int)
-> ((Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int))
-> (Id, (LetBinding, VarEnv Int))
-> VarEnv Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
forall a b. (a, b) -> b
snd) [(Id, (LetBinding, VarEnv Int))]
bindsFvs
      bodyFVs   = Getting (UniqMap (Var Any)) Term Id
-> (Id -> UniqMap (Var Any)) -> Term -> UniqMap (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqMap (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqMap (Var Any)
forall a. Var a -> UniqMap (Var Any)
unitVarSet Term
body
      (il,keep) = List.partition (isInteresting allOccs prims bodyFVs)
                                 bindsFvs
      keep'     = HasCallStack =>
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)]
-> [LetBinding]
InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)]
-> [LetBinding]
inlineBndrsCleanup InScopeSet
is1 ([(Id, (LetBinding, VarEnv Int))] -> VarEnv (LetBinding, VarEnv Int)
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv [(Id, (LetBinding, VarEnv Int))]
il) VarEnv (LetBinding, VarEnv Int, Mark)
forall a. VarEnv a
emptyVarEnv
                ([(LetBinding, VarEnv Int)] -> [LetBinding])
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
forall a b. (a -> b) -> a -> b
$ ((Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int))
-> [(Id, (LetBinding, VarEnv Int))] -> [(LetBinding, VarEnv Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
forall a b. (a, b) -> b
snd [(Id, (LetBinding, VarEnv Int))]
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 :: VarEnv Int
-> CompiledPrimMap
-> UniqMap (Var Any)
-> (Id, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs CompiledPrimMap
prims UniqMap (Var Any)
bodyFVs (Id
id_,((Id
_,((Term, [Either Term Type]) -> Term
forall a b. (a, b) -> a
fst((Term, [Either Term Type]) -> Term)
-> (Term -> (Term, [Either Term Type])) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> (Term, [Either Term Type])
collectArgs) -> Term
tm),VarEnv Int
_))
      -- 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.
      | Name Term -> NameSort
forall a. Name a -> NameSort
nameSort (Id -> Name Term
forall a. Var a -> Name a
varName Id
id_) NameSort -> NameSort -> Bool
forall a. Eq a => a -> a -> Bool
/= NameSort
User
      , Id
id_ Id -> UniqMap (Var Any) -> Bool
forall a. Var a -> UniqMap (Var Any) -> Bool
`notElemVarSet` UniqMap (Var Any)
bodyFVs
      = case Term
tm of
          Prim PrimInfo
pInfo
            | let nm :: Text
nm = PrimInfo -> Text
primName PrimInfo
pInfo
            , Just (GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim -> Just p :: CompiledPrimitive
p@(BlackBox {})) <- Text -> CompiledPrimMap -> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm CompiledPrimMap
prims
            , TemplateKind
TExpr <- CompiledPrimitive -> TemplateKind
forall a b c d. Primitive a b c d -> TemplateKind
kind CompiledPrimitive
p
            , Just Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
allOccs
            , Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            -> Bool
True
            | Bool
otherwise
            -> PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text
"Clash.Explicit.SimIO.bindSimIO#"]
          Case Term
_ Type
_ [Alt
_] -> Bool
True
          Data DataCon
_ -> Bool
True
          Case Term
_ Type
aTy (Alt
_:Alt
_:[Alt]
_)
            | TyConApp TyConName
nm [Type]
_ <- Type -> TypeView
tyView Type
aTy
            , TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
Text.showt ''SimIO.SimIO
            -> Bool
True
          Term
_ -> Bool
False
      | Id
id_ Id -> UniqMap (Var Any) -> Bool
forall a. Var a -> UniqMap (Var Any) -> Bool
`notElemVarSet` UniqMap (Var Any)
bodyFVs
      = case Term
tm of
          Prim PrimInfo
pInfo
            | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem`
                        [ Name -> Text
forall a. Show a => a -> Text
Text.showt 'SimIO.openFile
                        , Name -> Text
forall a. Show a => a -> Text
Text.showt 'SimIO.getChar
                        , Name -> Text
forall a. Show a => a -> Text
Text.showt 'SimIO.isEOF
                        ]
            , Just Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
allOccs
            , Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            -> Bool
True
            | Bool
otherwise
            -> PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text
"Clash.Explicit.SimIO.bindSimIO#"]
          Case Term
_ Type
_ [(DataPat DataCon
dcE [TyVar]
_ [Id]
_,Term
_)]
            -> let nm :: Text
nm = (Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dcE))
               in -- Inlines WW projection that exposes internals of the BitVector types
                  Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
Text.showt 'BV.BV  Bool -> Bool -> Bool
||
                  Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
Text.showt 'BV.Bit Bool -> Bool -> Bool
||
                  -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset)
                  Text
"GHC.Classes" Text -> Text -> Bool
`Text.isPrefixOf` Text
nm
          Case Term
_ Type
aTy (Alt
_:Alt
_:[Alt]
_)
            | TyConApp TyConName
nm [Type]
_ <- Type -> TypeView
tyView Type
aTy
            , TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
Text.showt ''SimIO.SimIO
            -> Bool
True
          Term
_ -> Bool
False

    isInteresting VarEnv Int
_ CompiledPrimMap
_ UniqMap (Var Any)
_ (Id, (LetBinding, VarEnv Int))
_ = Bool
False

inlineCleanup TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
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. Only runs at
-- synthesis boundaries (NOINLINE/OPAQUE functions) to avoid running too early
-- on functions that might be inlined later. See #3036.
collapseRHSNoops :: HasCallStack => NormRewrite
collapseRHSNoops :: HasCallStack => NormRewrite
collapseRHSNoops TransformContext
_ letrec :: Term
letrec@(Let Bind Term
letBind Term
body) = do
  (curFunId, _) <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra (f :: Type -> Type).
Functor f =>
((Id, SrcSpan) -> f (Id, SrcSpan))
-> RewriteState extra -> f (RewriteState extra)
curFun
  curBinding <- lookupVarEnv curFunId <$> Lens.use bindings
  case curBinding of
    Just Binding Term
binding | InlineSpec -> Bool
isNoInline (Binding Term -> InlineSpec
forall a. Binding a -> InlineSpec
bindingSpec Binding Term
binding) -> do
      -- Explicitly match on Let instead of using LetRec, because we need to
      -- preserve the structure. See https://github.com/clash-lang/clash-compiler/issues/3044.
      case Bind Term
letBind of
        Term.Rec [LetBinding]
binds -> do
          binds1 <- (LetBinding -> RewriteMonad NormalizeState LetBinding)
-> [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM LetBinding -> RewriteMonad NormalizeState LetBinding
forall {a}.
HasType a =>
(a, Term) -> RewriteMonad NormalizeState (a, Term)
runCollapseNoop [LetBinding]
binds
          pure (Let (Term.Rec binds1) body)
        Term.NonRec Id
b0 Term
e0 -> do
          (b1, e1) <- LetBinding -> RewriteMonad NormalizeState LetBinding
forall {a}.
HasType a =>
(a, Term) -> RewriteMonad NormalizeState (a, Term)
runCollapseNoop (Id
b0, Term
e0)
          pure (Let (Term.NonRec b1 e1) body)
    Maybe (Binding Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
letrec
  where
    runCollapseNoop :: (a, Term) -> RewriteMonad NormalizeState (a, Term)
runCollapseNoop (a, Term)
orig =
      MaybeT (RewriteMonad NormalizeState) (a, Term)
-> RewriteMonad NormalizeState (Maybe (a, Term))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT ((a, Term) -> MaybeT (RewriteMonad NormalizeState) (a, Term)
forall {a}.
HasType a =>
(a, Term) -> MaybeT (RewriteMonad NormalizeState) (a, Term)
collapseNoop (a, Term)
orig) RewriteMonad NormalizeState (Maybe (a, Term))
-> (Maybe (a, Term) -> RewriteMonad NormalizeState (a, Term))
-> RewriteMonad NormalizeState (a, Term)
forall a b.
RewriteMonad NormalizeState a
-> (a -> RewriteMonad NormalizeState b)
-> RewriteMonad NormalizeState b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= RewriteMonad NormalizeState (a, Term)
-> ((a, Term) -> RewriteMonad NormalizeState (a, Term))
-> Maybe (a, Term)
-> RewriteMonad NormalizeState (a, Term)
forall b a. b -> (a -> b) -> Maybe a -> b
Maybe.maybe ((a, Term) -> RewriteMonad NormalizeState (a, Term)
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a, Term)
orig) (a, Term) -> RewriteMonad NormalizeState (a, Term)
forall a extra. a -> RewriteMonad extra a
changed

    collapseNoop :: (a, Term) -> MaybeT (RewriteMonad NormalizeState) (a, Term)
collapseNoop (a
iD,Term
term) = do
      (Prim info,args) <- (Term, [Either Term Type])
-> MaybeT (RewriteMonad NormalizeState) (Term, [Either Term Type])
forall a. a -> MaybeT (RewriteMonad NormalizeState) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Term, [Either Term Type])
 -> MaybeT (RewriteMonad NormalizeState) (Term, [Either Term Type]))
-> (Term, [Either Term Type])
-> MaybeT (RewriteMonad NormalizeState) (Term, [Either Term Type])
forall a b. (a -> b) -> a -> b
$ Term -> (Term, [Either Term Type])
collectArgs Term
term
      identity         <- getIdentity info $ lefts args
      collapsed        <- collapseToIdentity iD identity
      return (iD,collapsed)

    collapseToIdentity :: p -> Term -> m Term
collapseToIdentity p
iD Term
identity = do
      tcm <- Getting TyConMap RewriteEnv TyConMap -> m TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
      let aTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
identity
          bTy = p -> Type
forall a. HasType a => a -> Type
coreTypeOf p
iD
      return $ primUCo `TyApp` aTy `TyApp` bTy `App` identity

    getIdentity :: PrimInfo -> [Term] -> MaybeT (RewriteMonad NormalizeState) Term
getIdentity PrimInfo
primInfo [Term]
termArgs = do
      WorkIdentity idIdx noopIdxs <- WorkInfo -> MaybeT (RewriteMonad NormalizeState) WorkInfo
forall a. a -> MaybeT (RewriteMonad NormalizeState) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (WorkInfo -> MaybeT (RewriteMonad NormalizeState) WorkInfo)
-> WorkInfo -> MaybeT (RewriteMonad NormalizeState) WorkInfo
forall a b. (a -> b) -> a -> b
$ PrimInfo -> WorkInfo
primWorkInfo PrimInfo
primInfo
      mapM_ (getTermArg termArgs >=> isNoop >=> Monad.guard) noopIdxs
      getTermArg termArgs idIdx

    getTermArg :: [b] -> Int -> m b
getTermArg [b]
args Int
i = do
      Bool -> m ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
Monad.guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [b] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [b]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      b -> m b
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ [b]
args [b] -> Int -> b
forall a. HasCallStack => [a] -> Int -> a
!! Int
i

    isNoop :: Term -> MaybeT (RewriteMonad NormalizeState) Bool
isNoop (Var Id
i) = do
      binding     <- RewriteMonad NormalizeState (Maybe (Binding Term))
-> MaybeT (RewriteMonad NormalizeState) (Binding Term)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (RewriteMonad NormalizeState (Maybe (Binding Term))
 -> MaybeT (RewriteMonad NormalizeState) (Binding Term))
-> RewriteMonad NormalizeState (Maybe (Binding Term))
-> MaybeT (RewriteMonad NormalizeState) (Binding Term)
forall a b. (a -> b) -> a -> b
$ Id -> VarEnv (Binding Term) -> Maybe (Binding Term)
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
i (VarEnv (Binding Term) -> Maybe (Binding Term))
-> RewriteMonad NormalizeState (VarEnv (Binding Term))
-> RewriteMonad NormalizeState (Maybe (Binding Term))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (VarEnv (Binding Term))
  (RewriteState NormalizeState)
  (VarEnv (Binding Term))
-> RewriteMonad NormalizeState (VarEnv (Binding Term))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv (Binding Term))
  (RewriteState NormalizeState)
  (VarEnv (Binding Term))
forall extra (f :: Type -> Type).
Functor f =>
(VarEnv (Binding Term) -> f (VarEnv (Binding Term)))
-> RewriteState extra -> f (RewriteState extra)
bindings
      isRecursive <- lift $ isRecursiveBndr $ bindingId binding
      Monad.guard $ not isRecursive
      isNoop $ bindingTerm binding
    isNoop (Prim PrimInfo{primWorkInfo :: PrimInfo -> WorkInfo
primWorkInfo=WorkIdentity Int
_ []}) = Bool -> MaybeT (RewriteMonad NormalizeState) Bool
forall a. a -> MaybeT (RewriteMonad NormalizeState) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
    isNoop (Lam Id
x Term
e) = Id
-> (Term, [Either Term Type])
-> MaybeT (RewriteMonad NormalizeState) Bool
forall {m :: Type -> Type}.
(Alternative m, MonadFail m) =>
Id -> (Term, [Either Term Type]) -> m Bool
isNoopApp Id
x (Term -> (Term, [Either Term Type])
collectArgs Term
e)
    isNoop Term
_ = Bool -> MaybeT (RewriteMonad NormalizeState) Bool
forall a. a -> MaybeT (RewriteMonad NormalizeState) a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
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 :: Id -> (Term, [Either Term Type]) -> m Bool
isNoopApp Id
x (Var Id
y,[]) = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
y)
    isNoopApp Id
x (Prim PrimInfo{primWorkInfo :: PrimInfo -> WorkInfo
primWorkInfo=WorkIdentity Int
i []},[Either Term Type]
args) = do
      arg <- [Term] -> Int -> m Term
forall {m :: Type -> Type} {b}.
(Monad m, Alternative m) =>
[b] -> Int -> m b
getTermArg ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args) Int
i
      isNoopApp x (collectArgs arg)
    isNoopApp Id
x (Prim PrimInfo{Text
primName :: PrimInfo -> Text
primName :: Text
primName},[Either Term Type]
args)
      | Text
primName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
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 {}) <- [Term] -> Int -> m Term
forall {m :: Type -> Type} {b}.
(Monad m, Alternative m) =>
[b] -> Int -> m b
getTermArg ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
lefts [Either Term Type]
args) Int
1
      isNoopApp x (collectArgs arg)
    isNoopApp Id
_ (Term, [Either Term Type])
_ = Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

collapseRHSNoops TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
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 :: HasCallStack => NormRewrite
inlineNonRep TransformContext
ctx0 e0 :: Term
e0@(Case {}) = do
  r <- RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState (Term, Any)
forall a.
RewriteMonad NormalizeState a
-> RewriteMonad NormalizeState (a, Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen (HasCallStack => Term -> RewriteMonad NormalizeState Term
Term -> RewriteMonad NormalizeState Term
inlineNonRepWorker Term
e0)
  case r of
    (Term
e1, Any -> Bool
Monoid.getAny -> Bool
True) ->
      Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e1
    (Term
e1, Any
_) -> 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
        (Term
subj0,Type
typ,[Alt]
alts) = case Term
e1 of
          Case Term
s Type
t [Alt]
a -> (Term
s,Type
t,[Alt]
a)
          Term
_ -> [Char] -> (Term, Type, [Alt])
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error, inlineNonRep triggered on a non-Case:" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                      Term -> [Char]
forall p. PrettyPrec p => p -> [Char]
showPpr Term
e1)
        TransformContext InScopeSet
inScope Context
ctx1 = TransformContext
ctx0
        ctx2 :: TransformContext
ctx2 = InScopeSet -> Context -> TransformContext
TransformContext InScopeSet
inScope (CoreContext
CaseScrutCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx1)

      RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState (Term, Any)
forall a.
RewriteMonad NormalizeState a
-> RewriteMonad NormalizeState (a, Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen (HasCallStack => NormRewrite
NormRewrite
inlineNonRep TransformContext
ctx2 Term
subj0) RewriteMonad NormalizeState (Term, Any)
-> ((Term, Any) -> RewriteMonad NormalizeState Term)
-> RewriteMonad NormalizeState Term
forall a b.
RewriteMonad NormalizeState a
-> (a -> RewriteMonad NormalizeState b)
-> RewriteMonad NormalizeState b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Term
subj1, Any -> Bool
Monoid.getAny -> Bool
True) ->
          Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Type -> [Alt] -> Term
Case Term
subj1 Type
typ [Alt]
alts)
        (Term
subj1, Any
_) -> do
          let ([Pat]
pats, [Term]
rhss0) = [Alt] -> ([Pat], [Term])
forall a b. [(a, b)] -> ([a], [b])
unzip [Alt]
alts
          rhss1 <- (Term -> RewriteMonad NormalizeState Term)
-> [Term] -> RewriteMonad NormalizeState [Term]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (HasCallStack => NormRewrite
NormRewrite
inlineNonRep TransformContext
ctx2) [Term]
rhss0
          pure (Case subj1 typ (zip pats rhss1))

inlineNonRep TransformContext
ctx Term
e =
  -- All non-case statements are simply traversed. TODO: are there other special
  -- cases like 'Case' that would warrant an optimization like ^ ?
  NormRewrite -> NormRewrite
forall (m :: Type -> Type). Monad m => Transform m -> Transform m
allR HasCallStack => NormRewrite
NormRewrite
inlineNonRep TransformContext
ctx Term
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 :: HasCallStack => Term -> RewriteMonad NormalizeState Term
inlineNonRepWorker e :: Term
e@(Case Term
scrut Type
altsTy [Alt]
alts)
  | (Var Id
f, [Either Term Type]
args,[TickInfo]
ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks Term
scrut
  , Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
f
  = do
    (cf,_)    <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra (f :: Type -> Type).
Functor f =>
((Id, SrcSpan) -> f (Id, SrcSpan))
-> RewriteState extra -> f (RewriteState extra)
curFun
    isInlined <- zoomExtra (alreadyInlined f cf)
    limit     <- Lens.view inlineLimit
    tcm       <- Lens.view tcCache
    let
      scrutTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
scrut

      -- Constraint dictionary inlining always terminates, so we ignore the
      -- usual inline safeguards.
      notClassTy = Bool -> Bool
not (TyConMap -> Type -> Bool
isClassTy TyConMap
tcm Type
scrutTy)
      overLimit = Bool
notClassTy Bool -> Bool -> Bool
&& (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Maybe.fromMaybe Int
0 Maybe Int
isInlined) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
      (Bool
True, Just Binding Term
b) -> do
        if Bool
overLimit then
          [Char]
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. [Char] -> a -> a
trace ($(curLoc) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [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.
          |]) (Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e)
        else do
          Bool
-> RewriteMonad NormalizeState () -> RewriteMonad NormalizeState ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.when Bool
notClassTy (State NormalizeState () -> RewriteMonad NormalizeState ()
forall extra a. State extra a -> RewriteMonad extra a
zoomExtra (Id -> Id -> State NormalizeState ()
addNewInline Id
f Id
cf))

          let scrutBody0 :: Term
scrutBody0 = Term -> [TickInfo] -> Term
mkTicks (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b) (Id -> TickInfo
mkInlineTick Id
f TickInfo -> [TickInfo] -> [TickInfo]
forall a. a -> [a] -> [a]
: [TickInfo]
ticks)
          let scrutBody1 :: Term
scrutBody1 = Term -> [Either Term Type] -> Term
mkApps Term
scrutBody0 [Either Term Type]
args

          Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> RewriteMonad NormalizeState Term)
-> Term -> RewriteMonad NormalizeState Term
forall a b. (a -> b) -> a -> b
$ Term -> Type -> [Alt] -> Term
Case Term
scrutBody1 Type
altsTy [Alt]
alts
      (Bool, Maybe (Binding Term))
_ ->
        Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

inlineNonRepWorker Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
e
{-# SCC inlineNonRepWorker #-}

inlineOrLiftNonRep :: HasCallStack => NormRewrite
inlineOrLiftNonRep :: HasCallStack => NormRewrite
inlineOrLiftNonRep TransformContext
ctx eLet :: Term
eLet@(Letrec [LetBinding]
_ Term
body) =
    (LetBinding -> RewriteMonad NormalizeState Bool)
-> (Term -> LetBinding -> Bool) -> NormRewrite
forall extra.
(LetBinding -> RewriteMonad extra Bool)
-> (Term -> LetBinding -> Bool) -> Rewrite extra
inlineOrLiftBinders LetBinding -> RewriteMonad NormalizeState Bool
nonRepTest Term -> LetBinding -> Bool
inlineTest TransformContext
ctx Term
eLet
  where
    bodyFreeOccs :: VarEnv Int
bodyFreeOccs = Term -> VarEnv Int
countFreeOccurances Term
body

    nonRepTest :: (Id, Term) -> NormalizeSession Bool
    nonRepTest :: LetBinding -> RewriteMonad NormalizeState Bool
nonRepTest (Id {varType :: forall a. Var a -> Type
varType = Type
ty}, Term
_)
      = Bool -> Bool
not (Bool -> Bool)
-> RewriteMonad NormalizeState Bool
-> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either [Char] FilteredHWType)))
-> CustomReprs -> Bool -> TyConMap -> Type -> Bool
representableType ((CustomReprs
  -> TyConMap
  -> Type
  -> State HWMap (Maybe (Either [Char] FilteredHWType)))
 -> CustomReprs -> Bool -> TyConMap -> Type -> Bool)
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Type
      -> State HWMap (Maybe (Either [Char] FilteredHWType)))
-> RewriteMonad
     NormalizeState (CustomReprs -> Bool -> TyConMap -> Type -> Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either [Char] FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either [Char] FilteredHWType)))
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Type
      -> State HWMap (Maybe (Either [Char] FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either [Char] FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either [Char] FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either [Char] FilteredHWType)))
typeTranslator
                                   RewriteMonad
  NormalizeState (CustomReprs -> Bool -> TyConMap -> Type -> Bool)
-> RewriteMonad NormalizeState CustomReprs
-> RewriteMonad NormalizeState (Bool -> TyConMap -> Type -> Bool)
forall a b.
RewriteMonad NormalizeState (a -> b)
-> RewriteMonad NormalizeState a -> RewriteMonad NormalizeState b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Getting CustomReprs RewriteEnv CustomReprs
-> RewriteMonad NormalizeState CustomReprs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CustomReprs RewriteEnv CustomReprs
Getter RewriteEnv CustomReprs
customReprs
                                   RewriteMonad NormalizeState (Bool -> TyConMap -> Type -> Bool)
-> RewriteMonad NormalizeState Bool
-> RewriteMonad NormalizeState (TyConMap -> Type -> Bool)
forall a b.
RewriteMonad NormalizeState (a -> b)
-> RewriteMonad NormalizeState a -> RewriteMonad NormalizeState b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
                                   RewriteMonad NormalizeState (TyConMap -> Type -> Bool)
-> RewriteMonad NormalizeState TyConMap
-> RewriteMonad NormalizeState (Type -> Bool)
forall a b.
RewriteMonad NormalizeState (a -> b)
-> RewriteMonad NormalizeState a -> RewriteMonad NormalizeState b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Getting TyConMap RewriteEnv TyConMap
-> RewriteMonad NormalizeState TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
                                   RewriteMonad NormalizeState (Type -> Bool)
-> RewriteMonad NormalizeState Type
-> RewriteMonad NormalizeState Bool
forall a b.
RewriteMonad NormalizeState (a -> b)
-> RewriteMonad NormalizeState a -> RewriteMonad NormalizeState b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> RewriteMonad NormalizeState Type
forall a. a -> RewriteMonad NormalizeState a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
ty)
    nonRepTest LetBinding
_ = Bool -> RewriteMonad NormalizeState Bool
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

    inlineTest :: Term -> (Id, Term) -> Bool
    inlineTest :: Term -> LetBinding -> Bool
inlineTest Term
e (Id
id_, Term
e') =
      -- We do __NOT__ inline:
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or
        [ -- 1. recursive let-binders
          -- id_ `elemFreeVars` e' -- <= already checked in inlineOrLiftBinders
          -- 2. join points (which are not void-wrappers)
          Id -> Term -> Bool
isJoinPointIn Id
id_ Term
e Bool -> Bool -> Bool
&& Bool -> Bool
not (Term -> Bool
isVoidWrapper Term
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
        , Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) (Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
bodyFreeOccs)
        ]

inlineOrLiftNonRep TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC inlineOrLiftNonRep #-}

-- | Inline anything of type `SimIO`: IO actions cannot be shared
inlineSimIO :: HasCallStack => NormRewrite
inlineSimIO :: HasCallStack => NormRewrite
inlineSimIO = (Term -> LetBinding -> RewriteMonad NormalizeState Bool)
-> NormRewrite
forall extra.
(Term -> LetBinding -> RewriteMonad extra Bool) -> Rewrite extra
inlineBinders Term -> LetBinding -> RewriteMonad NormalizeState Bool
forall {a} {m :: Type -> Type} {p} {b}.
(HasType a, Monad m) =>
p -> (a, b) -> m Bool
test
  where
    test :: p -> (a, b) -> m Bool
test p
_ (a
i,b
_) = case Type -> TypeView
tyView (a -> Type
forall a. HasType a => a -> Type
coreTypeOf a
i) of
      TyConApp TyConName
tc [Type]
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tc Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Text
forall a. Show a => a -> Text
Text.showt ''SimIO.SimIO
      TypeView
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
{-# SCC inlineSimIO #-}

-- | Inline small functions
inlineSmall :: HasCallStack => NormRewrite
inlineSmall :: HasCallStack => NormRewrite
inlineSmall TransformContext
_ e :: Term
e@(Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Var Id
f,[Either Term Type]
args,[TickInfo]
ticks)) = do
  untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
True Term
e
  topEnts <- Lens.view topEntities
  let lv = Id -> Bool
forall a. Var a -> Bool
isLocalId Id
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 Binding Term
b -> do
          isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
f
          if not isRecBndr && not (isNoInline (bindingSpec b)) && termSize (bindingTerm b) < sizeLimit
             then do
               let tm = Term -> [TickInfo] -> Term
mkTicks (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b) (Id -> TickInfo
mkInlineTick Id
f TickInfo -> [TickInfo] -> [TickInfo]
forall a. a -> [a] -> [a]
: [TickInfo]
ticks)
               changed $ mkApps tm args
             else return e

        Maybe (Binding Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

inlineSmall TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC inlineSmall #-}

-- | Inline work-free functions, i.e. fully applied functions that evaluate to
-- a constant
inlineWorkFree :: HasCallStack => NormRewrite
inlineWorkFree :: HasCallStack => NormRewrite
inlineWorkFree TransformContext
_ e :: Term
e@(Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Var Id
f,args :: [Either Term Type]
args@(Either Term Type
_:[Either Term Type]
_),[TickInfo]
ticks))
  = do
    tcm <- Getting TyConMap RewriteEnv TyConMap
-> RewriteMonad NormalizeState TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
    let eTy = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e
    argsHaveWork <- or <$> mapM (either expressionHasWork
                                        (const (pure False)))
                                args
    untranslatable <- isUntranslatableType True eTy
    topEnts <- Lens.view topEntities
    let isSignal = TyConMap -> Type -> Bool
isSignalType TyConMap
tcm Type
eTy
    let lv = Id -> Bool
forall a. Var a -> Bool
isLocalId Id
f
    let isTopEnt = Id -> UniqMap (Var Any) -> Bool
forall a. Var a -> UniqMap (Var Any) -> Bool
elemVarSet Id
f UniqMap (Var Any)
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 Binding Term
b -> do
            isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
f
            if isRecBndr
               then return e
               else do
                 let tm = Term -> [TickInfo] -> Term
mkTicks (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b) (Id -> TickInfo
mkInlineTick Id
f TickInfo -> [TickInfo] -> [TickInfo]
forall a. a -> [a] -> [a]
: [TickInfo]
ticks)
                 changed $ mkApps tm args

          Maybe (Binding Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
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 :: Term -> m Bool
expressionHasWork Term
e' = do
      let fvIds :: [Id]
fvIds = Getting (Endo [Id]) Term Id -> Term -> [Id]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [Id]) Term Id
Fold Term Id
freeLocalIds Term
e'
      tcm   <- Getting TyConMap RewriteEnv TyConMap -> m TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
      let e'Ty     = TyConMap -> Term -> Type
forall a. InferType a => TyConMap -> a -> Type
inferCoreTypeOf TyConMap
tcm Term
e'
          isSignal = TyConMap -> Type -> Bool
isSignalType TyConMap
tcm Type
e'Ty
      return (not (null fvIds) || isSignal)

inlineWorkFree TransformContext
_ e :: Term
e@(Var Id
f) = do
  tcm <- Getting TyConMap RewriteEnv TyConMap
-> RewriteMonad NormalizeState TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Getter RewriteEnv TyConMap
tcCache
  let fTy      = Id -> Type
forall a. HasType a => a -> Type
coreTypeOf Id
f
      closed   = Bool -> Bool
not (TyConMap -> Type -> Bool
isPolyFunCoreTy TyConMap
tcm Type
fTy)
      isSignal = TyConMap -> Type -> Bool
isSignalType TyConMap
tcm Type
fTy
  untranslatable <- isUntranslatableType True fTy
  topEnts <- Lens.view topEntities
  let gv = Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
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 Binding Term
top -> do
          isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
f
          if isRecBndr
             then return e
             else do
              let topB = Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
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)
        Maybe (Binding Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    else return e

inlineWorkFree TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall a. a -> RewriteMonad NormalizeState a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC inlineWorkFree #-}