    {-|
      Copyright  :  (C) 2012-2016, University of Twente,
                        2016-2017, Myrtle Software Ltd,
                        2017-2022, Google Inc.,
                        2021-2022, 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 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))

    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 :: 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} {p}.
    MonadReader RewriteEnv m =>
    p -> LetBinding -> m Bool
    test
      where
        test :: p -> LetBinding -> m Bool
    test p
    _ (Var Term
    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 (Var Term
    i Var Term -> Term -> Bool
    forall a. HasFreeVars a => Var a -> a -> Bool
    `notElemFreeVars` Term
    e)
          Bool
    _    -> do
            TyConMap
    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
            case TyConMap -> Term -> Bool
    isWorkFreeIsh TyConMap
    tcm Term
    e 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))
    -> Int
    -> 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) Int
    u Int
    _ =
      case Int
    -> VarEnv (LetBinding, VarEnv Int, Mark)
    -> Maybe (LetBinding, VarEnv Int, Mark)
    forall a. Int -> VarEnv a -> Maybe a
    lookupVarEnvDirectly Int
    u VarEnv (LetBinding, VarEnv Int, Mark)
    doneInl of
        Maybe (LetBinding, VarEnv Int, Mark)
    Nothing -> case Int
    -> VarEnv (LetBinding, VarEnv Int)
    -> Maybe (LetBinding, VarEnv Int)
    forall a. Int -> VarEnv a -> Maybe a
    lookupVarEnvDirectly Int
    u VarEnv (LetBinding, VarEnv Int)
    origInl of
          Maybe (LetBinding, VarEnv Int)
    Nothing ->
            -- let-binding not found, cannot extend the substitution
            if Int -> InScopeSet -> Bool
    elemUniqInScopeSet Int
    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 ((Var Term
    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))
     -> Int
     -> 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 -> Int -> b -> a) -> a -> VarEnv b -> a
    foldlWithUniqueVarEnv'
                    (HasCallStack =>
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> Int
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> 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.
                    , Var Term
    -> (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 Var Term
    v ((Var Term
    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 Var Term
    v Var Term -> 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'
                  , Var Term
    -> (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 Var Term
    v ((Var Term
    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 -> Var Term -> Term -> Subst
    extendIdSubst (Subst -> Maybe Subst -> Subst
    forall a. a -> Maybe a -> a
    Maybe.fromMaybe (InScopeSet -> Subst
    mkSubst InScopeSet
    isN) Maybe Subst
    substM) Var Term
    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.
                  , Var Term
    -> (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 Var Term
    v ((Var Term
    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 ((Var Term
    v,Term
    e),VarEnv Int
    eFVs,Mark
    Done) ->
          ( Subst -> Maybe Subst
    forall a. a -> Maybe a
    Just (Subst -> Var Term -> Term -> Subst
    extendIdSubst (Subst -> Maybe Subst -> Subst
    forall a. a -> Maybe a -> a
    Maybe.fromMaybe (InScopeSet -> Subst
    mkSubst InScopeSet
    isN) Maybe Subst
    substM) Var Term
    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
    $ \((Var Term
    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))
     -> Int
     -> 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 -> Int -> b -> a) -> a -> VarEnv b -> a
    foldlWithUniqueVarEnv'
                               (HasCallStack =>
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> Int
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> 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 (Var Term
    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 (((Var Term
    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))
     -> Int
     -> 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 -> Int -> b -> a) -> a -> VarEnv b -> a
    foldlWithUniqueVarEnv'
                                (HasCallStack =>
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> Int
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    InScopeSet
    -> VarEnv (LetBinding, VarEnv Int)
    -> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
    -> Int
    -> 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  (Var Term
    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
      CompiledPrimMap
    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
    is1       = InScopeSet -> [Var Term] -> InScopeSet
    forall a. InScopeSet -> [Var a] -> InScopeSet
    extendInScopeSetList InScopeSet
    is0 ((LetBinding -> Var Term) -> [LetBinding] -> [Var Term]
    forall a b. (a -> b) -> [a] -> [b]
    map LetBinding -> Var Term
    forall a b. (a, b) -> a
    fst [LetBinding]
    binds)
          bindsFvs :: [(Var Term, (LetBinding, VarEnv Int))]
    bindsFvs  = (LetBinding -> (Var Term, (LetBinding, VarEnv Int)))
    -> [LetBinding] -> [(Var Term, (LetBinding, VarEnv Int))]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Var Term
    v,Term
    e) -> (Var Term
    v,((Var Term
    v,Term
    e),Term -> VarEnv Int
    countFreeOccurances Term
    e))) [LetBinding]
    binds
          allOccs :: VarEnv Int
    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
    $ ((Var Term, (LetBinding, VarEnv Int)) -> VarEnv Int)
    -> [(Var Term, (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)
    -> ((Var Term, (LetBinding, VarEnv Int))
        -> (LetBinding, VarEnv Int))
    -> (Var Term, (LetBinding, VarEnv Int))
    -> VarEnv Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .(Var Term, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
    forall a b. (a, b) -> b
    snd) [(Var Term, (LetBinding, VarEnv Int))]
    bindsFvs
          bodyFVs :: UniqMap (Var Any)
    bodyFVs   = Getting (UniqMap (Var Any)) Term (Var Term)
    -> (Var Term -> 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 (Var Term)
    Fold Term (Var Term)
    freeLocalIds Var Term -> UniqMap (Var Any)
    forall a. Var a -> UniqMap (Var Any)
    unitVarSet Term
    body
          ([(Var Term, (LetBinding, VarEnv Int))]
    il,[(Var Term, (LetBinding, VarEnv Int))]
    keep) = ((Var Term, (LetBinding, VarEnv Int)) -> Bool)
    -> [(Var Term, (LetBinding, VarEnv Int))]
    -> ([(Var Term, (LetBinding, VarEnv Int))],
        [(Var Term, (LetBinding, VarEnv Int))])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    List.partition (VarEnv Int
    -> CompiledPrimMap
    -> UniqMap (Var Any)
    -> (Var Term, (LetBinding, VarEnv Int))
    -> Bool
    isInteresting VarEnv Int
    allOccs CompiledPrimMap
    prims UniqMap (Var Any)
    bodyFVs)
                                     [(Var Term, (LetBinding, VarEnv Int))]
    bindsFvs
          keep' :: [LetBinding]
    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 ([(Var Term, (LetBinding, VarEnv Int))]
    -> VarEnv (LetBinding, VarEnv Int)
    forall a b. [(Var a, b)] -> VarEnv b
    mkVarEnv [(Var Term, (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
    $ ((Var Term, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int))
    -> [(Var Term, (LetBinding, VarEnv Int))]
    -> [(LetBinding, VarEnv Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Var Term, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
    forall a b. (a, b) -> b
    snd [(Var Term, (LetBinding, VarEnv Int))]
    keep

      if | [(Var Term, (LetBinding, VarEnv Int))] -> Bool
    forall a. [a] -> Bool
    forall (t :: Type -> Type) a. Foldable t => t a -> Bool
    null [(Var Term, (LetBinding, VarEnv Int))]
    il -> Term -> RewriteMonad NormalizeState Term
    forall a. a -> RewriteMonad NormalizeState a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return  ([LetBinding] -> Term -> Term
    Letrec [LetBinding]
    binds Term
    body)
         | [LetBinding] -> Bool
    forall a. [a] -> Bool
    forall (t :: Type -> Type) a. Foldable t => t a -> Bool
    null [LetBinding]
    keep' -> Term -> RewriteMonad NormalizeState Term
    forall a extra. a -> RewriteMonad extra a
    changed Term
    body
         | Bool
    otherwise -> Term -> RewriteMonad NormalizeState Term
    forall a extra. a -> RewriteMonad extra a
    changed ([LetBinding] -> Term -> Term
    Letrec [LetBinding]
    keep' Term
    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)
    -> (Var Term, (LetBinding, VarEnv Int))
    -> Bool
    isInteresting VarEnv Int
    allOccs CompiledPrimMap
    prims UniqMap (Var Any)
    bodyFVs (Var Term
    id_,((Var Term
    _,((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 (Var Term -> Name Term
    forall a. Var a -> Name a
    varName Var Term
    id_) NameSort -> NameSort -> Bool
    forall a. Eq a => a -> a -> Bool
    /= NameSort
    User
          , Var Term
    id_ Var Term -> 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 <- Var Term -> VarEnv Int -> Maybe Int
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    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
          | Var Term
    id_ Var Term -> 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 <- Var Term -> VarEnv Int -> Maybe Int
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    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]
    _ [Var Term]
    _,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)
    _ (Var Term, (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
    collapseRHSNoops :: HasCallStack => NormRewrite
    collapseRHSNoops :: HasCallStack => NormRewrite
    collapseRHSNoops TransformContext
    _ (Letrec [LetBinding]
    binds Term
    body) = do
      [LetBinding]
    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
      Term -> RewriteMonad NormalizeState Term
    forall a. a -> RewriteMonad NormalizeState a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Term -> RewriteMonad NormalizeState Term)
    -> Term -> RewriteMonad NormalizeState Term
    forall a b. (a -> b) -> a -> b
    $ [LetBinding] -> Term -> Term
    Letrec [LetBinding]
    binds1 Term
    body
      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 PrimInfo
    info,[Either Term Type]
    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
          Term
    identity         <- PrimInfo -> [Term] -> MaybeT (RewriteMonad NormalizeState) Term
    getIdentity PrimInfo
    info ([Term] -> MaybeT (RewriteMonad NormalizeState) Term)
    -> [Term] -> MaybeT (RewriteMonad NormalizeState) Term
    forall a b. (a -> b) -> a -> b
    $ [Either Term Type] -> [Term]
    forall a b. [Either a b] -> [a]
    lefts [Either Term Type]
    args
          Term
    collapsed        <- a -> Term -> MaybeT (RewriteMonad NormalizeState) Term
    forall {m :: Type -> Type} {p}.
    (MonadReader RewriteEnv m, HasType p) =>
    p -> Term -> m Term
    collapseToIdentity a
    iD Term
    identity
          (a, Term) -> MaybeT (RewriteMonad NormalizeState) (a, Term)
    forall a. a -> MaybeT (RewriteMonad NormalizeState) a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (a
    iD,Term
    collapsed)

        collapseToIdentity :: p -> Term -> m Term
    collapseToIdentity p
    iD Term
    identity = do
          TyConMap
    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 :: Type
    aTy = TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm Term
    identity
              bTy :: Type
    bTy = p -> Type
    forall a. HasType a => a -> Type
    coreTypeOf p
    iD
          Term -> m Term
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Term -> m Term) -> Term -> m Term
    forall a b. (a -> b) -> a -> b
    $ Term
    primUCo Term -> Type -> Term
    `TyApp` Type
    aTy Term -> Type -> Term
    `TyApp` Type
    bTy Term -> Term -> Term
    `App` Term
    identity

        getIdentity :: PrimInfo -> [Term] -> MaybeT (RewriteMonad NormalizeState) Term
    getIdentity PrimInfo
    primInfo [Term]
    termArgs = do
          WorkIdentity Int
    idIdx [Int]
    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
          (Int -> MaybeT (RewriteMonad NormalizeState) ())
    -> [Int] -> MaybeT (RewriteMonad NormalizeState) ()
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ ([Term] -> Int -> MaybeT (RewriteMonad NormalizeState) Term
    forall {m :: Type -> Type} {b}.
    (Monad m, Alternative m) =>
    [b] -> Int -> m b
    getTermArg [Term]
    termArgs (Int -> MaybeT (RewriteMonad NormalizeState) Term)
    -> (Term -> MaybeT (RewriteMonad NormalizeState) ())
    -> Int
    -> MaybeT (RewriteMonad NormalizeState) ()
    forall (m :: Type -> Type) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> Term -> MaybeT (RewriteMonad NormalizeState) Bool
    isNoop (Term -> MaybeT (RewriteMonad NormalizeState) Bool)
    -> (Bool -> MaybeT (RewriteMonad NormalizeState) ())
    -> Term
    -> MaybeT (RewriteMonad NormalizeState) ()
    forall (m :: Type -> Type) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> Bool -> MaybeT (RewriteMonad NormalizeState) ()
    forall (f :: Type -> Type). Alternative f => Bool -> f ()
    Monad.guard) [Int]
    noopIdxs
          [Term] -> Int -> MaybeT (RewriteMonad NormalizeState) Term
    forall {m :: Type -> Type} {b}.
    (Monad m, Alternative m) =>
    [b] -> Int -> m b
    getTermArg [Term]
    termArgs Int
    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 Var Term
    i) = do
          Binding Term
    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
    $ Var Term -> VarEnv (Binding Term) -> Maybe (Binding Term)
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    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
          Bool
    isRecursive <- RewriteMonad NormalizeState Bool
    -> MaybeT (RewriteMonad NormalizeState) Bool
    forall (m :: Type -> Type) a. Monad m => m a -> MaybeT m a
    forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift (RewriteMonad NormalizeState Bool
     -> MaybeT (RewriteMonad NormalizeState) Bool)
    -> RewriteMonad NormalizeState Bool
    -> MaybeT (RewriteMonad NormalizeState) Bool
    forall a b. (a -> b) -> a -> b
    $ Var Term -> RewriteMonad NormalizeState Bool
    isRecursiveBndr (Var Term -> RewriteMonad NormalizeState Bool)
    -> Var Term -> RewriteMonad NormalizeState Bool
    forall a b. (a -> b) -> a -> b
    $ Binding Term -> Var Term
    forall a. Binding a -> Var Term
    bindingId Binding Term
    binding
          Bool -> MaybeT (RewriteMonad NormalizeState) ()
    forall (f :: Type -> Type). Alternative f => Bool -> f ()
    Monad.guard (Bool -> MaybeT (RewriteMonad NormalizeState) ())
    -> Bool -> MaybeT (RewriteMonad NormalizeState) ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> Bool
    not Bool
    isRecursive
          Term -> MaybeT (RewriteMonad NormalizeState) Bool
    isNoop (Term -> MaybeT (RewriteMonad NormalizeState) Bool)
    -> Term -> MaybeT (RewriteMonad NormalizeState) Bool
    forall a b. (a -> b) -> a -> b
    $ Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    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 Var Term
    x Term
    e) = Var Term
    -> (Term, [Either Term Type])
    -> MaybeT (RewriteMonad NormalizeState) Bool
    forall {m :: Type -> Type}.
    (Alternative m, MonadFail m) =>
    Var Term -> (Term, [Either Term Type]) -> m Bool
    isNoopApp Var Term
    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 :: Var Term -> (Term, [Either Term Type]) -> m Bool
    isNoopApp Var Term
    x (Var Var Term
    y,[]) = Bool -> m Bool
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Var Term
    x Var Term -> Var Term -> Bool
    forall a. Eq a => a -> a -> Bool
    == Var Term
    y)
        isNoopApp Var Term
    x (Prim PrimInfo{primWorkInfo :: PrimInfo -> WorkInfo
    primWorkInfo=WorkIdentity Int
    i []},[Either Term Type]
    args) = do
          Term
    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
          Var Term -> (Term, [Either Term Type]) -> m Bool
    isNoopApp Var Term
    x (Term -> (Term, [Either Term Type])
    collectArgs Term
    arg)
        isNoopApp Var Term
    x (Prim PrimInfo{primName :: PrimInfo -> Text
    primName=Text
    "Clash.Class.BitPack.Internal.xToBV"},[Either Term Type]
    args) = 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 :: Term
    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
          Var Term -> (Term, [Either Term Type]) -> m Bool
    isNoopApp Var Term
    x (Term -> (Term, [Either Term Type])
    collectArgs Term
    arg)
        isNoopApp Var Term
    _ (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
      (Term, Any)
    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 (Term, Any)
    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
              [Term]
    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
              Term -> RewriteMonad NormalizeState Term
    forall a. a -> RewriteMonad NormalizeState a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Term -> Type -> [Alt] -> Term
    Case Term
    subj1 Type
    typ ([Pat] -> [Term] -> [Alt]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Pat]
    pats [Term]
    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 Var Term
    f, [Either Term Type]
    args,[TickInfo]
    ticks) <- Term -> (Term, [Either Term Type], [TickInfo])
    collectArgsTicks Term
    scrut
      , Var Term -> Bool
    forall a. Var a -> Bool
    isGlobalId Var Term
    f
      = do
        (Var Term
    cf,SrcSpan
    _)    <- Getting
      (Var Term, SrcSpan)
      (RewriteState NormalizeState)
      (Var Term, SrcSpan)
    -> RewriteMonad NormalizeState (Var Term, SrcSpan)
    forall s (m :: Type -> Type) a.
    MonadState s m =>
    Getting a s a -> m a
    Lens.use Getting
      (Var Term, SrcSpan)
      (RewriteState NormalizeState)
      (Var Term, SrcSpan)
    forall extra (f :: Type -> Type).
    Functor f =>
    ((Var Term, SrcSpan) -> f (Var Term, SrcSpan))
    -> RewriteState extra -> f (RewriteState extra)
    curFun
        Maybe Int
    isInlined <- State NormalizeState (Maybe Int)
    -> RewriteMonad NormalizeState (Maybe Int)
    forall extra a. State extra a -> RewriteMonad extra a
    zoomExtra (Var Term -> Var Term -> State NormalizeState (Maybe Int)
    alreadyInlined Var Term
    f Var Term
    cf)
        Int
    limit     <- Getting Int RewriteEnv Int -> RewriteMonad NormalizeState Int
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting Int RewriteEnv Int
    Getter RewriteEnv Int
    inlineLimit
        TyConMap
    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
          scrutTy :: Type
    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
    notClassTy = Bool -> Bool
    not (TyConMap -> Type -> Bool
    isClassTy TyConMap
    tcm Type
    scrutTy)
          overLimit :: Bool
    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

        Maybe (Binding Term)
    bodyMaybe   <- Var Term -> VarEnv (Binding Term) -> Maybe (Binding Term)
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    f (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
        Bool
    nonRepScrut <- 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
    scrutTy)
        case (Bool
    nonRepScrut, Maybe (Binding Term)
    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 (Var Term -> Var Term -> State NormalizeState ()
    addNewInline Var Term
    f Var Term
    cf))

              let scrutBody0 :: Term
    scrutBody0 = Term -> [TickInfo] -> Term
    mkTicks (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    b) (Var Term -> TickInfo
    mkInlineTick Var Term
    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 (Var Term
    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)
              Var Term -> Term -> Bool
    isJoinPointIn Var Term
    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) (Var Term -> VarEnv Int -> Maybe Int
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    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 Var Term
    f,[Either Term Type]
    args,[TickInfo]
    ticks)) = do
      Bool
    untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
    forall extra. Bool -> Term -> RewriteMonad extra Bool
    isUntranslatable Bool
    True Term
    e
      UniqMap (Var Any)
    topEnts <- Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    -> RewriteMonad NormalizeState (UniqMap (Var Any))
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    Lens' RewriteEnv (UniqMap (Var Any))
    topEntities
      let lv :: Bool
    lv = Var Term -> Bool
    forall a. Var a -> Bool
    isLocalId Var Term
    f
      if Bool
    untranslatable Bool -> Bool -> Bool
    || Var Term
    f Var Term -> UniqMap (Var Any) -> Bool
    forall a. Var a -> UniqMap (Var Any) -> Bool
    `elemVarSet` UniqMap (Var Any)
    topEnts Bool -> Bool -> Bool
    || Bool
    lv
        then 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
          VarEnv (Binding Term)
    bndrs <- 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
          Word
    sizeLimit <- Getting Word RewriteEnv Word -> RewriteMonad NormalizeState 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
    inlineFunctionLimit
          case Var Term -> VarEnv (Binding Term) -> Maybe (Binding Term)
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    f VarEnv (Binding Term)
    bndrs of
            -- Don't inline recursive expressions
            Just Binding Term
    b -> do
              Bool
    isRecBndr <- Var Term -> RewriteMonad NormalizeState Bool
    isRecursiveBndr Var Term
    f
              if Bool -> Bool
    not Bool
    isRecBndr Bool -> Bool -> Bool
    && Bool -> Bool
    not (InlineSpec -> Bool
    isNoInline (Binding Term -> InlineSpec
    forall a. Binding a -> InlineSpec
    bindingSpec Binding Term
    b)) Bool -> Bool -> Bool
    && Term -> Word
    termSize (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    b) Word -> Word -> Bool
    forall a. Ord a => a -> a -> Bool
    < Word
    sizeLimit
                 then do
                   let tm :: Term
    tm = Term -> [TickInfo] -> Term
    mkTicks (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    b) (Var Term -> TickInfo
    mkInlineTick Var Term
    f TickInfo -> [TickInfo] -> [TickInfo]
    forall a. a -> [a] -> [a]
    : [TickInfo]
    ticks)
                   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 -> [Either Term Type] -> Term
    mkApps Term
    tm [Either Term Type]
    args
                 else Term -> RewriteMonad NormalizeState Term
    forall a. a -> RewriteMonad NormalizeState a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Term
    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 Var Term
    f,args :: [Either Term Type]
    args@(Either Term Type
    _:[Either Term Type]
    _),[TickInfo]
    ticks))
      = do
        TyConMap
    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 :: Type
    eTy = TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm Term
    e
        Bool
    argsHaveWork <- [Bool] -> Bool
    forall (t :: Type -> Type). Foldable t => t Bool -> Bool
    or ([Bool] -> Bool)
    -> RewriteMonad NormalizeState [Bool]
    -> RewriteMonad NormalizeState Bool
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> (Either Term Type -> RewriteMonad NormalizeState Bool)
    -> [Either Term Type] -> RewriteMonad NormalizeState [Bool]
    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 ((Term -> RewriteMonad NormalizeState Bool)
    -> (Type -> RewriteMonad NormalizeState Bool)
    -> Either Term Type
    -> RewriteMonad NormalizeState Bool
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Term -> RewriteMonad NormalizeState Bool
    forall {m :: Type -> Type}.
    MonadReader RewriteEnv m =>
    Term -> m Bool
    expressionHasWork
                                            (RewriteMonad NormalizeState Bool
    -> Type -> RewriteMonad NormalizeState Bool
    forall a b. a -> b -> a
    const (Bool -> RewriteMonad NormalizeState Bool
    forall a. a -> RewriteMonad NormalizeState a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure Bool
    False)))
                                    [Either Term Type]
    args
        Bool
    untranslatable <- Bool -> Type -> RewriteMonad NormalizeState Bool
    forall extra. Bool -> Type -> RewriteMonad extra Bool
    isUntranslatableType Bool
    True Type
    eTy
        UniqMap (Var Any)
    topEnts <- Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    -> RewriteMonad NormalizeState (UniqMap (Var Any))
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    Lens' RewriteEnv (UniqMap (Var Any))
    topEntities
        let isSignal :: Bool
    isSignal = TyConMap -> Type -> Bool
    isSignalType TyConMap
    tcm Type
    eTy
        let lv :: Bool
    lv = Var Term -> Bool
    forall a. Var a -> Bool
    isLocalId Var Term
    f
        let isTopEnt :: Bool
    isTopEnt = Var Term -> UniqMap (Var Any) -> Bool
    forall a. Var a -> UniqMap (Var Any) -> Bool
    elemVarSet Var Term
    f UniqMap (Var Any)
    topEnts
        if Bool
    untranslatable Bool -> Bool -> Bool
    || Bool
    isSignal Bool -> Bool -> Bool
    || Bool
    argsHaveWork Bool -> Bool -> Bool
    || Bool
    lv Bool -> Bool -> Bool
    || Bool
    isTopEnt
          then 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
            VarEnv (Binding Term)
    bndrs <- 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
            case Var Term -> VarEnv (Binding Term) -> Maybe (Binding Term)
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    f VarEnv (Binding Term)
    bndrs of
              -- Don't inline recursive expressions
              Just Binding Term
    b -> do
                Bool
    isRecBndr <- Var Term -> RewriteMonad NormalizeState Bool
    isRecursiveBndr Var Term
    f
                if Bool
    isRecBndr
                   then 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
                     let tm :: Term
    tm = Term -> [TickInfo] -> Term
    mkTicks (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    b) (Var Term -> TickInfo
    mkInlineTick Var Term
    f TickInfo -> [TickInfo] -> [TickInfo]
    forall a. a -> [a] -> [a]
    : [TickInfo]
    ticks)
                     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 -> [Either Term Type] -> Term
    mkApps Term
    tm [Either Term Type]
    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 :: [Var Term]
    fvIds = Getting (Endo [Var Term]) Term (Var Term) -> Term -> [Var Term]
    forall a s. Getting (Endo [a]) s a -> s -> [a]
    Lens.toListOf Getting (Endo [Var Term]) Term (Var Term)
    Fold Term (Var Term)
    freeLocalIds Term
    e'
          TyConMap
    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 :: Type
    e'Ty     = TyConMap -> Term -> Type
    forall a. InferType a => TyConMap -> a -> Type
    inferCoreTypeOf TyConMap
    tcm Term
    e'
              isSignal :: Bool
    isSignal = TyConMap -> Type -> Bool
    isSignalType TyConMap
    tcm Type
    e'Ty
          Bool -> m Bool
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Bool -> Bool
    not ([Var Term] -> Bool
    forall a. [a] -> Bool
    forall (t :: Type -> Type) a. Foldable t => t a -> Bool
    null [Var Term]
    fvIds) Bool -> Bool -> Bool
    || Bool
    isSignal)

    inlineWorkFree TransformContext
    _ e :: Term
    e@(Var Var Term
    f) = do
      TyConMap
    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 :: Type
    fTy      = Var Term -> Type
    forall a. HasType a => a -> Type
    coreTypeOf Var Term
    f
          closed :: Bool
    closed   = Bool -> Bool
    not (TyConMap -> Type -> Bool
    isPolyFunCoreTy TyConMap
    tcm Type
    fTy)
          isSignal :: Bool
    isSignal = TyConMap -> Type -> Bool
    isSignalType TyConMap
    tcm Type
    fTy
      Bool
    untranslatable <- Bool -> Type -> RewriteMonad NormalizeState Bool
    forall extra. Bool -> Type -> RewriteMonad extra Bool
    isUntranslatableType Bool
    True Type
    fTy
      UniqMap (Var Any)
    topEnts <- Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    -> RewriteMonad NormalizeState (UniqMap (Var Any))
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting (UniqMap (Var Any)) RewriteEnv (UniqMap (Var Any))
    Lens' RewriteEnv (UniqMap (Var Any))
    topEntities
      let gv :: Bool
    gv = Var Term -> Bool
    forall a. Var a -> Bool
    isGlobalId Var Term
    f
      if Bool
    closed Bool -> Bool -> Bool
    && Var Term
    f Var Term -> UniqMap (Var Any) -> Bool
    forall a. Var a -> UniqMap (Var Any) -> Bool
    `notElemVarSet` UniqMap (Var Any)
    topEnts Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    untranslatable Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    isSignal Bool -> Bool -> Bool
    && Bool
    gv
        then do
          VarEnv (Binding Term)
    bndrs <- 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
          case Var Term -> VarEnv (Binding Term) -> Maybe (Binding Term)
    forall b a. Var b -> VarEnv a -> Maybe a
    lookupVarEnv Var Term
    f VarEnv (Binding Term)
    bndrs of
            -- Don't inline recursive expressions
            Just Binding Term
    top -> do
              Bool
    isRecBndr <- Var Term -> RewriteMonad NormalizeState Bool
    isRecursiveBndr Var Term
    f
              if Bool
    isRecBndr
                 then 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
                  let topB :: Term
    topB = Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    top
                  Word
    sizeLimit <- Getting Word RewriteEnv Word -> RewriteMonad NormalizeState 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
    inlineWFCacheLimit
                  -- caching only worth it from a certain size onwards, otherwise
                  -- the caching mechanism itself brings more of an overhead.
                  if Term -> Word
    termSize Term
    topB Word -> Word -> Bool
    forall a. Ord a => a -> a -> Bool
    < Word
    sizeLimit then
                    Term -> RewriteMonad NormalizeState Term
    forall a extra. a -> RewriteMonad extra a
    changed Term
    topB
                  else do
                    Binding Term
    b <- Bool -> Var Term -> Binding Term -> NormalizeSession (Binding Term)
    normalizeTopLvlBndr Bool
    False Var Term
    f Binding Term
    top
                    Term -> RewriteMonad NormalizeState Term
    forall a extra. a -> RewriteMonad extra a
    changed (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    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 Term -> RewriteMonad NormalizeState Term
    forall a. a -> RewriteMonad NormalizeState a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return Term
    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 #-}