{-|
  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.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)

#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.Basic             (InlineSpec (..))
#else
import BasicTypes                  (InlineSpec (..))
#endif

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 :: 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 (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 (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Word
0 -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
            Word
n -> Bool -> m Bool
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 (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 :: 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 :: 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 :: 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 (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
    test p
_ (a, Term)
_ = Bool -> m Bool
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 :: 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 (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 :: UniqSet (Var Any)
bodyFVs   = Getting (UniqSet (Var Any)) Term (Var Term)
-> (Var Term -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> UniqSet (Var Any)
forall a. Var a -> UniqSet (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
-> UniqSet (Var Any)
-> (Var Term, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs CompiledPrimMap
prims UniqSet (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 (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Var Term, (LetBinding, VarEnv Int))]
il -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return  ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
body)
     | [LetBinding] -> 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
-> UniqSet (Var Any)
-> (Var Term, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs CompiledPrimMap
prims UniqSet (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 -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (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 (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 -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (Var Any)
bodyFVs
      = case Term
tm of
          Prim PrimInfo
pInfo
            | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> 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 (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
_ UniqSet (Var Any)
_ (Var Term, (LetBinding, VarEnv Int))
_ = Bool
False

inlineCleanup TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
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 :: 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)
mapM LetBinding -> RewriteMonad NormalizeState LetBinding
forall a.
HasType a =>
(a, Term) -> RewriteMonad NormalizeState (a, Term)
runCollapseNoop [LetBinding]
binds
  Term -> RewriteMonad NormalizeState Term
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 (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 (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 (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) a.
(MonadReader RewriteEnv m, HasType a) =>
a -> Term -> m Term
collapseToIdentity a
iD Term
identity
      (a, Term) -> MaybeT (RewriteMonad NormalizeState) (a, Term)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
iD,Term
collapsed)

    collapseToIdentity :: a -> Term -> m Term
collapseToIdentity a
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 = a -> Type
forall a. HasType a => a -> Type
coreTypeOf a
iD
      Term -> m Term
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 (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 (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 (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. [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. Lens' (RewriteState extra) (VarEnv (Binding Term))
bindings
      Bool
isRecursive <- RewriteMonad NormalizeState Bool
-> MaybeT (RewriteMonad NormalizeState) Bool
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 (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 (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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

collapseRHSNoops TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
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 :: NormRewrite
inlineNonRep TransformContext
ctx0 e0 :: Term
e0@(Case {}) = do
  (Term, Any)
r <- RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState (Term, 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 (m :: Type -> Type) a. Monad m => a -> m a
return Term
e1
    (~(Case Term
subj0 Type
typ [Alt]
alts), 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
        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 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 (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 (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)
mapM (HasCallStack => NormRewrite
NormRewrite
inlineNonRep TransformContext
ctx2) [Term]
rhss0
          Term -> RewriteMonad NormalizeState Term
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 :: 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. Lens' (RewriteState extra) (Var Term, SrcSpan)
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. Lens' (RewriteState extra) (VarEnv (Binding Term))
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 (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 (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Bool -> RewriteMonad NormalizeState Bool
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 (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 (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> RewriteMonad NormalizeState Type
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 ($([Char]
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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

inlineOrLiftNonRep :: HasCallStack => NormRewrite
inlineOrLiftNonRep :: 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 (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 (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Bool -> RewriteMonad NormalizeState Bool
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 (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 (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> RewriteMonad NormalizeState Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
ty)
    nonRepTest LetBinding
_ = Bool -> RewriteMonad NormalizeState Bool
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 (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 :: 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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
{-# SCC inlineSimIO #-}

-- | Inline small functions
inlineSmall :: HasCallStack => NormRewrite
inlineSmall :: 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
  UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (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 -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
topEnts Bool -> Bool -> Bool
|| Bool
lv
    then Term -> RewriteMonad NormalizeState Term
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. Lens' (RewriteState extra) (VarEnv (Binding Term))
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
&& Binding Term -> InlineSpec
forall a. Binding a -> InlineSpec
bindingSpec Binding Term
b InlineSpec -> InlineSpec -> Bool
forall a. Eq a => a -> a -> Bool
/= InlineSpec
NoInline 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 (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

inlineSmall TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
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 :: 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)
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 (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
    UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (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 -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
elemVarSet Var Term
f UniqSet (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 (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. Lens' (RewriteState extra) (VarEnv (Binding Term))
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 (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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return (Bool -> Bool
not ([Var Term] -> 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
  UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (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 -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (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. Lens' (RewriteState extra) (VarEnv (Binding Term))
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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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