{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016-2017, Myrtle Software Ltd,
                    2017-2018, Google Inc.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Transformations of the Normalization process
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Normalize.Transformations
  ( caseLet
  , caseCon
  , caseCase
  , caseElemNonReachable
  , elemExistentials
  , inlineNonRep
  , inlineOrLiftNonRep
  , typeSpec
  , nonRepSpec
  , etaExpansionTL
  , nonRepANF
  , bindConstantVar
  , constantSpec
  , makeANF
  , deadCode
  , topLet
  , recToLetRec
  , inlineWorkFree
  , inlineHO
  , inlineSmall
  , simpleCSE
  , reduceConst
  , reduceNonRepPrim
  , caseFlat
  , disjointExpressionConsolidation
  , removeUnusedExpr
  , inlineCleanup
  , inlineBndrsCleanup
  , flattenLet
  , splitCastWork
  , inlineCast
  , caseCast
  , letCast
  , eliminateCastCast
  , argCastSpec
  , etaExpandSyn
  , appPropFast
  , separateArguments
  , separateLambda
  , xOptimize
  , setupMultiResultPrim
  , inlineSimIO
  )
where

import           Control.Exception           (throw)
import           Control.Lens                ((^.),_1,_2)
import qualified Control.Lens                as Lens
import qualified Control.Monad               as Monad
import           Control.Monad.Extra         (orM)
import           Control.Monad.State         (StateT (..), modify)
import           Control.Monad.State.Strict  (evalState)
import           Control.Monad.Writer        (lift, listen)
import           Control.Monad.Trans.Except  (runExcept)
import           Data.Coerce                 (coerce)
import           Data.Default
import qualified Data.Either                 as Either
import qualified Data.HashMap.Lazy           as HashMap
import qualified Data.HashMap.Strict         as HashMapS
import           Data.List                   ((\\))
import qualified Data.List                   as List
import qualified Data.List.Extra             as List
import qualified Data.Maybe                  as Maybe
import qualified Data.Monoid                 as Monoid
import qualified Data.Primitive.ByteArray    as BA
import qualified Data.Text                   as Text
#if MIN_VERSION_base(4,15,0)
import           GHC.Num.Integer             (Integer (..))
#else
import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..))
#endif
import           TextShow                    (TextShow(showt))

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

import           Clash.Annotations.Primitive (extractPrim)
import           Clash.Core.DataCon          (DataCon (..))
import           Clash.Core.EqSolver
import           Clash.Core.Name
  (mkUnsafeInternalName, Name (..), NameSort (..), mkUnsafeSystemName, nameOcc)
import           Clash.Core.FreeVars
  (localIdOccursIn, localIdsDoNotOccurIn, freeLocalIds, termFreeTyVars,
   typeFreeVars, localVarsDoNotOccurIn, localIdDoesNotOccurIn,
   countFreeOccurances)
import           Clash.Core.Literal          (Literal (..))
import           Clash.Core.Pretty           (PrettyOptions(..), showPpr, showPpr')
import           Clash.Core.Subst
import           Clash.Core.Term
import           Clash.Core.TermInfo
import           Clash.Core.Type             (Type (..), TypeView (..), applyFunTy,
                                              isPolyFunCoreTy, isClassTy,
                                              normalizeType, splitFunForallTy,
                                              splitFunTy,
                                              tyView, mkPolyFunTy, coreView,
                                              LitTy (..), coreView1, mkTyConApp)
import           Clash.Core.TyCon            (TyConMap, tyConDataCons)
import           Clash.Core.Util
  (Projections (..), isSignalType, mkVec, tyNatSize, undefinedTm,
   shouldSplit, inverseTopSortLetBindings, mkInternalVar, mkSelectorCase)
import           Clash.Core.Var
  (Id, TyVar, Var (..), isGlobalId, isLocalId, mkLocalId)
import           Clash.Core.VarEnv
  (InScopeSet, VarEnv, VarSet, elemVarSet,
   emptyVarEnv, extendInScopeSet, extendInScopeSetList, lookupVarEnv,
   notElemVarSet, unionVarEnvWith, unionInScope, unitVarEnv,
   unitVarSet, mkVarSet, mkInScopeSet, uniqAway, elemInScopeSet, elemVarEnv,
   foldlWithUniqueVarEnv', lookupVarEnvDirectly, extendVarEnv, unionVarEnv,
   eltsVarEnv, mkVarEnv, elemUniqInScopeSet)
import           Clash.Debug
import           Clash.Driver.Types          (Binding(..), DebugLevel (..))
import           Clash.Netlist.BlackBox.Types (Element(Err))
import           Clash.Netlist.BlackBox.Util (getUsedArguments)
import           Clash.Netlist.Types         (BlackBox(..), HWType (..), FilteredHWType(..))
import           Clash.Netlist.Util
  (coreTypeToHWType, representableType, splitNormalized, bindsExistentials)
import           Clash.Normalize.DEC
import           Clash.Normalize.PrimitiveReductions
import           Clash.Normalize.Types
import           Clash.Normalize.Util
import           Clash.Primitives.Types
  (Primitive(..), TemplateKind(TExpr), CompiledPrimMap, UsedArguments(..))
import           Clash.Rewrite.Combinators
import           Clash.Rewrite.Types
import           Clash.Rewrite.Util
import           Clash.Unique
import           Clash.Util
import qualified Clash.Util.Interpolate as I

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
forall extra. LetBinding -> RewriteMonad extra Bool
nonRepTest Term -> LetBinding -> Bool
inlineTest TransformContext
ctx Term
eLet
  where
    bodyFreeOccs :: VarEnv Int
bodyFreeOccs = Term -> VarEnv Int
countFreeOccurances Term
body

    nonRepTest :: (Id, Term) -> RewriteMonad extra Bool
    nonRepTest :: LetBinding -> RewriteMonad extra Bool
nonRepTest (Id {varType :: forall a. Var a -> Kind
varType = Kind
ty}, Term
_)
      = Bool -> Bool
not (Bool -> Bool)
-> RewriteMonad extra Bool -> RewriteMonad extra Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CustomReprs
 -> TyConMap
 -> Kind
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> Bool -> TyConMap -> Kind -> Bool
representableType ((CustomReprs
  -> TyConMap
  -> Kind
  -> State HWMap (Maybe (Either String FilteredHWType)))
 -> CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad
     extra
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     extra (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     extra
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
                                   RewriteMonad
  extra (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad extra CustomReprs
-> RewriteMonad extra (Bool -> TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Getting CustomReprs RewriteEnv CustomReprs
-> RewriteMonad extra CustomReprs
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting CustomReprs RewriteEnv CustomReprs
Lens' RewriteEnv CustomReprs
customReprs
                                   RewriteMonad extra (Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad extra Bool
-> RewriteMonad extra (TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Bool -> RewriteMonad extra Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
                                   RewriteMonad extra (TyConMap -> Kind -> Bool)
-> RewriteMonad extra TyConMap -> RewriteMonad extra (Kind -> Bool)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Getting TyConMap RewriteEnv TyConMap -> RewriteMonad extra TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
                                   RewriteMonad extra (Kind -> Bool)
-> RewriteMonad extra Kind -> RewriteMonad extra Bool
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Kind -> RewriteMonad extra Kind
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Kind
ty)
    nonRepTest LetBinding
_ = Bool -> RewriteMonad extra 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_ `localIdOccursIn` 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 #-}

{- [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.
-}

-- | Specialize functions on their type
typeSpec :: HasCallStack => NormRewrite
typeSpec :: NormRewrite
typeSpec TransformContext
ctx e :: Term
e@(TyApp Term
e1 Kind
ty)
  | (Var {},  [Either Term Kind]
args) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e1
  , [TyVar] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting (Endo [TyVar]) Kind TyVar -> Kind -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Kind TyVar
Fold Kind TyVar
typeFreeVars Kind
ty
  , ([Term]
_, []) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
  = NormRewrite
specializeNorm TransformContext
ctx Term
e

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

-- | Specialize functions on their non-representable argument
nonRepSpec :: HasCallStack => NormRewrite
nonRepSpec :: NormRewrite
nonRepSpec TransformContext
ctx e :: Term
e@(App Term
e1 Term
e2)
  | (Var {}, [Either Term Kind]
args) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e1
  , ([Term]
_, [])     <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
  , [TyVar] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting (Endo [TyVar]) Term TyVar -> Term -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Term TyVar
Fold Term TyVar
termFreeTyVars Term
e2
  = 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
Lens' RewriteEnv TyConMap
tcCache
       let e2Ty :: Kind
e2Ty = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e2
       let localVar :: Bool
localVar = Term -> Bool
isLocalVar Term
e2
       Bool
nonRepE2 <- 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
 -> Kind
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> Bool -> TyConMap -> Kind -> Bool
representableType ((CustomReprs
  -> TyConMap
  -> Kind
  -> State HWMap (Maybe (Either String FilteredHWType)))
 -> CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
                                              RewriteMonad
  NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState CustomReprs
-> RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> 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
Lens' RewriteEnv CustomReprs
customReprs
                                              RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState Bool
-> RewriteMonad NormalizeState (TyConMap -> Kind -> 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 -> Kind -> Bool)
-> RewriteMonad NormalizeState TyConMap
-> RewriteMonad NormalizeState (Kind -> 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
Lens' RewriteEnv TyConMap
tcCache
                                              RewriteMonad NormalizeState (Kind -> Bool)
-> RewriteMonad NormalizeState Kind
-> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Kind -> RewriteMonad NormalizeState Kind
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Kind
e2Ty)
       if Bool
nonRepE2 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
localVar
         then do
           Term
e2' <- Term -> RewriteMonad NormalizeState Term
inlineInternalSpecialisationArgument Term
e2
           NormRewrite
specializeNorm TransformContext
ctx (Term -> Term -> Term
App Term
e1 Term
e2')
         else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
  where
    -- | If the argument on which we're specialising ia an internal function,
    -- one created by the compiler, then inline that function before we
    -- specialise.
    --
    -- We need to do this because otherwise the specialisation history won't
    -- recognize the new specialisation argument as something the function has
    -- already been specialized on
    inlineInternalSpecialisationArgument
      :: Term
      -> NormalizeSession Term
    inlineInternalSpecialisationArgument :: Term -> RewriteMonad NormalizeState Term
inlineInternalSpecialisationArgument Term
app
      | (Var Var Term
f,[Either Term Kind]
fArgs,[TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
app
      = do
        Maybe (Binding Term)
fTmM <- 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
        case Maybe (Binding Term)
fTmM of
          Just Binding Term
b
            | Name Term -> NameSort
forall a. Name a -> NameSort
nameSort (Var Term -> Name Term
forall a. Var a -> Name a
varName (Binding Term -> Var Term
forall a. Binding a -> Var Term
bindingId Binding Term
b)) NameSort -> NameSort -> Bool
forall a. Eq a => a -> a -> Bool
== NameSort
Internal
            -> (Any -> Any)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall extra a.
(Any -> Any) -> RewriteMonad extra a -> RewriteMonad extra a
censor (Any -> Any -> Any
forall a b. a -> b -> a
const Any
forall a. Monoid a => a
mempty)
                      (NormRewrite -> NormRewrite
forall m. Rewrite m -> Rewrite m
topdownR HasCallStack => NormRewrite
NormRewrite
appPropFast TransformContext
ctx
                        (Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b) [TickInfo]
ticks) [Either Term Kind]
fArgs))
          Maybe (Binding Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
app
      | Bool
otherwise = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
app

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

-- | Lift the let-bindings out of the subject of a Case-decomposition
caseLet :: HasCallStack => NormRewrite
caseLet :: NormRewrite
caseLet (TransformContext InScopeSet
is0 Context
_) (Case (Term -> (Term, [TickInfo])
collectTicks -> (Letrec [LetBinding]
xes Term
e,[TickInfo]
ticks)) Kind
ty [Alt]
alts) = do
  -- Note [CaseLet deshadow]
  -- Imagine
  --
  -- @
  -- case (let x = u in e) of {p -> a}
  -- @
  --
  -- where `a` has a free variable named `x`.
  --
  -- Simply transforming the above to:
  --
  -- @
  -- let x = u in case e of {p -> a}
  -- @
  --
  -- would be very bad, because now the let-binding captures the free x variable
  -- in a.
  --
  -- We must therefor rename `x` so that it doesn't capture the free variables
  -- in the alternative:
  --
  -- @
  -- let x1 = u[x:=x1] in case e[x:=x1] of {p -> a}
  -- @
  --
  -- It is safe to over-approximate the free variables in `a` by simply taking
  -- the current InScopeSet.
  let ([LetBinding]
xes1,Term
e1) = HasCallStack =>
InScopeSet -> [LetBinding] -> Term -> ([LetBinding], Term)
InScopeSet -> [LetBinding] -> Term -> ([LetBinding], Term)
deshadowLetExpr InScopeSet
is0 [LetBinding]
xes Term
e
  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec ((LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks)) [LetBinding]
xes1)
                  (Term -> Kind -> [Alt] -> Term
Case (Term -> [TickInfo] -> Term
mkTicks Term
e1 [TickInfo]
ticks) Kind
ty [Alt]
alts))

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

-- | Remove non-reachable alternatives. For example, consider:
--
--    data STy ty where
--      SInt :: Int -> STy Int
--      SBool :: Bool -> STy Bool
--
--    f :: STy ty -> ty
--    f (SInt b) = b + 1
--    f (SBool True) = False
--    f (SBool False) = True
--    {-# NOINLINE f #-}
--
--    g :: STy Int -> Int
--    g = f
--
-- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore
-- unreachable. Additional information can be found at:
-- https://github.com/clash-lang/clash-compiler/pull/465
caseElemNonReachable :: HasCallStack => NormRewrite
caseElemNonReachable :: NormRewrite
caseElemNonReachable TransformContext
_ case0 :: Term
case0@(Case Term
scrut Kind
altsTy [Alt]
alts0) = 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
Lens' RewriteEnv TyConMap
tcCache

  let ([Alt]
altsAbsurd, [Alt]
altsOther) = (Alt -> Bool) -> [Alt] -> ([Alt], [Alt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (TyConMap -> Alt -> Bool
isAbsurdAlt TyConMap
tcm) [Alt]
alts0
  case [Alt]
altsAbsurd of
    [] -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
case0
    [Alt]
_  -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> RewriteMonad NormalizeState Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> RewriteMonad NormalizeState Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt (Term -> Kind -> [Alt] -> Term
Case Term
scrut Kind
altsTy [Alt]
altsOther)

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

-- | Tries to eliminate existentials by using heuristics to determine what the
-- existential should be. For example, consider Vec:
--
--    data Vec :: Nat -> Type -> Type where
--      Nil       :: Vec 0 a
--      Cons x xs :: a -> Vec n a -> Vec (n + 1) a
--
-- Thus, 'null' (annotated with existentials) could look like:
--
--    null :: forall n . Vec n Bool -> Bool
--    null v =
--      case v of
--        Nil  {n ~ 0}                                     -> True
--        Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False
--
-- When it's applied to a vector of length 5, this becomes:
--
--    null :: Vec 5 Bool -> Bool
--    null v =
--      case v of
--        Nil  {5 ~ 0}                                     -> True
--        Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False
--
-- This function solves 'n1' and replaces every occurrence with its solution. A
-- very limited number of solutions are currently recognized: only adds (such
-- as in the example) will be solved.
elemExistentials :: HasCallStack => NormRewrite
elemExistentials :: NormRewrite
elemExistentials (TransformContext InScopeSet
is0 Context
_) (Case Term
scrut Kind
altsTy [Alt]
alts0) = 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
Lens' RewriteEnv TyConMap
tcCache

  [Alt]
alts1 <- (Alt -> RewriteMonad NormalizeState Alt)
-> [Alt] -> RewriteMonad NormalizeState [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InScopeSet -> TyConMap -> Alt -> RewriteMonad NormalizeState Alt
go InScopeSet
is0 TyConMap
tcm) [Alt]
alts0
  Term -> RewriteMonad NormalizeState Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt (Term -> Kind -> [Alt] -> Term
Case Term
scrut Kind
altsTy [Alt]
alts1)

 where
    -- Eliminate free type variables if possible
    go :: InScopeSet -> TyConMap -> (Pat, Term) -> NormalizeSession (Pat, Term)
    go :: InScopeSet -> TyConMap -> Alt -> RewriteMonad NormalizeState Alt
go InScopeSet
is2 TyConMap
tcm alt :: Alt
alt@(DataPat DataCon
dc [TyVar]
exts0 [Var Term]
xs0, Term
term0) =
      case TyConMap -> VarSet -> [(Kind, Kind)] -> [(TyVar, Kind)]
solveNonAbsurds TyConMap
tcm ([TyVar] -> VarSet
forall a. [Var a] -> VarSet
mkVarSet [TyVar]
exts0) (TyConMap -> Alt -> [(Kind, Kind)]
altEqs TyConMap
tcm Alt
alt) of
        -- No equations solved:
        [] -> Alt -> RewriteMonad NormalizeState Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt
        -- One or more equations solved:
        [(TyVar, Kind)]
sols ->
          Alt -> RewriteMonad NormalizeState Alt
forall a extra. a -> RewriteMonad extra a
changed (Alt -> RewriteMonad NormalizeState Alt)
-> RewriteMonad NormalizeState Alt
-> RewriteMonad NormalizeState Alt
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< InScopeSet -> TyConMap -> Alt -> RewriteMonad NormalizeState Alt
go InScopeSet
is2 TyConMap
tcm (DataCon -> [TyVar] -> [Var Term] -> Pat
DataPat DataCon
dc [TyVar]
exts1 [Var Term]
xs1, Term
term1)
          where
            -- Substitute solution in existentials and applied types
            is3 :: InScopeSet
is3   = InScopeSet -> [TyVar] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is2 [TyVar]
exts0
            xs1 :: [Var Term]
xs1   = (Var Term -> Var Term) -> [Var Term] -> [Var Term]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Var Term -> Var Term
forall a. HasCallStack => Subst -> Var a -> Var a
substTyInVar (Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is3) [(TyVar, Kind)]
sols)) [Var Term]
xs0
            exts1 :: [TyVar]
exts1 = HasCallStack => InScopeSet -> [TyVar] -> [(TyVar, Kind)] -> [TyVar]
InScopeSet -> [TyVar] -> [(TyVar, Kind)] -> [TyVar]
substInExistentialsList InScopeSet
is2 [TyVar]
exts0 [(TyVar, Kind)]
sols

            -- Substitute solution in term.
            is4 :: InScopeSet
is4       = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is3 [Var Term]
xs1
            subst :: Subst
subst     = Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is4) [(TyVar, Kind)]
sols
            term1 :: Term
term1     = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"Replacing tyVar due to solved eq" Subst
subst Term
term0

    go InScopeSet
_ TyConMap
_ Alt
alt = Alt -> RewriteMonad NormalizeState Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt

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

-- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives
caseCase :: HasCallStack => NormRewrite
caseCase :: NormRewrite
caseCase (TransformContext InScopeSet
is0 Context
_) e :: Term
e@(Case (Term -> Term
stripTicks -> Case Term
scrut Kind
alts1Ty [Alt]
alts1) Kind
alts2Ty [Alt]
alts2)
  = do
    Bool
ty1Rep <- (CustomReprs
 -> TyConMap
 -> Kind
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> Bool -> TyConMap -> Kind -> Bool
representableType ((CustomReprs
  -> TyConMap
  -> Kind
  -> State HWMap (Maybe (Either String FilteredHWType)))
 -> CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
                                RewriteMonad
  NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState CustomReprs
-> RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> 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
Lens' RewriteEnv CustomReprs
customReprs
                                RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState Bool
-> RewriteMonad NormalizeState (TyConMap -> Kind -> 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 -> Kind -> Bool)
-> RewriteMonad NormalizeState TyConMap
-> RewriteMonad NormalizeState (Kind -> 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
Lens' RewriteEnv TyConMap
tcCache
                                RewriteMonad NormalizeState (Kind -> Bool)
-> RewriteMonad NormalizeState Kind
-> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Kind -> RewriteMonad NormalizeState Kind
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Kind
alts1Ty
    if Bool -> Bool
not Bool
ty1Rep
      -- Deshadow to prevent accidental capture of free variables of inner
      -- case. Imagine:
      --
      --   case (case a of {x -> x}) of {_ -> x}
      --
      -- 'x' is introduced the inner 'case' and used (as a free variable) in
      -- the outer one. The goal of 'caseCase' is to rewrite cases such that
      -- their subjects aren't cases. This is achieved by 'pushing' the outer
      -- case to all the alternatives of the inner one. Naively doing so in
      -- this example would cause an accidental capture:
      --
      --   case a of {x -> case x of {_ -> x}}
      --
      -- Suddenly, the 'x' in the alternative of the inner case statement
      -- refers to the one introduced by the outer one, instead of being a
      -- free variable. To prevent this, we deshadow the alternatives of the
      -- original inner case. We now end up with:
      --
      --   case a of {x1 -> case x1 of {_ -> x}}
      --
      then let newAlts :: [Alt]
newAlts = (Alt -> Alt) -> [Alt] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map
                           ((Term -> Term) -> Alt -> Alt
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\Term
altE -> Term -> Kind -> [Alt] -> Term
Case Term
altE Kind
alts2Ty [Alt]
alts2))
                           ((Alt -> Alt) -> [Alt] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => InScopeSet -> Alt -> Alt
InScopeSet -> Alt -> Alt
deShadowAlt InScopeSet
is0) [Alt]
alts1)
           in  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 -> Kind -> [Alt] -> Term
Case Term
scrut Kind
alts2Ty [Alt]
newAlts
      else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

-- | 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 Kind
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 -> Kind -> [Alt] -> Term
Case Term
subj1 Kind
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 -> Kind -> [Alt] -> Term
Case Term
subj1 Kind
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 Kind
altsTy [Alt]
alts)
  | (Var Var Term
f, [Either Term Kind]
args,[TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [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 (RewriteState NormalizeState) Int
-> RewriteMonad NormalizeState Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Int NormalizeState)
-> RewriteState NormalizeState
-> Const Int (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Int NormalizeState)
 -> RewriteState NormalizeState
 -> Const Int (RewriteState NormalizeState))
-> ((Int -> Const Int Int)
    -> NormalizeState -> Const Int NormalizeState)
-> Getting Int (RewriteState NormalizeState) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int)
-> NormalizeState -> Const Int NormalizeState
Lens' NormalizeState 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
Lens' RewriteEnv TyConMap
tcCache
    let
      scrutTy :: Kind
scrutTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
scrut

      -- Constraint dictionary inlining always terminates, so we ignore the
      -- usual inline safeguards.
      notClassTy :: Bool
notClassTy = Bool -> Bool
not (TyConMap -> Kind -> Bool
isClassTy TyConMap
tcm Kind
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
 -> Kind
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> Bool -> TyConMap -> Kind -> Bool
representableType ((CustomReprs
  -> TyConMap
  -> Kind
  -> State HWMap (Maybe (Either String FilteredHWType)))
 -> CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
                                              RewriteMonad
  NormalizeState (CustomReprs -> Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState CustomReprs
-> RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> 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
Lens' RewriteEnv CustomReprs
customReprs
                                              RewriteMonad NormalizeState (Bool -> TyConMap -> Kind -> Bool)
-> RewriteMonad NormalizeState Bool
-> RewriteMonad NormalizeState (TyConMap -> Kind -> 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 -> Kind -> Bool)
-> RewriteMonad NormalizeState TyConMap
-> RewriteMonad NormalizeState (Kind -> 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
Lens' RewriteEnv TyConMap
tcCache
                                              RewriteMonad NormalizeState (Kind -> Bool)
-> RewriteMonad NormalizeState Kind
-> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Kind -> RewriteMonad NormalizeState Kind
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Kind
scrutTy)
    case (Bool
nonRepScrut, Maybe (Binding Term)
bodyMaybe) of
      (Bool
True, Just Binding Term
b) -> do
        if Bool
overLimit then
          String
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. String -> a -> a
trace ($(String
curLoc) String -> String -> String
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 Kind] -> Term
mkApps Term
scrutBody0 [Either Term Kind]
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 -> Kind -> [Alt] -> Term
Case Term
scrutBody1 Kind
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 #-}


caseCon :: HasCallStack => NormRewrite
caseCon :: NormRewrite
caseCon = String -> NormRewrite -> NormRewrite
forall extra. String -> Rewrite extra -> Rewrite extra
apply String
"caseOneAlt" ((Term -> RewriteMonad NormalizeState Term) -> NormRewrite
forall a b. a -> b -> a
const Term -> RewriteMonad NormalizeState Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt) NormRewrite -> NormRewrite -> NormRewrite
forall m. Rewrite m -> Rewrite m -> Rewrite m
>-! HasCallStack => NormRewrite
NormRewrite
caseCon'

-- | Specialize a Case-decomposition (replace by the RHS of an alternative) if
-- the subject is (an application of) a DataCon; or if there is only a single
-- alternative that doesn't reference variables bound by the pattern.
--
-- Note [CaseCon deshadow]
--
-- Imagine:
--
-- @
-- case D (f a b) (g x y) of
--   D a b -> h a
-- @
--
-- rewriting this to:
--
-- @
-- let a = f a b
-- in  h a
-- @
--
-- is very bad because the newly introduced let-binding now captures the free
-- variable 'a' in 'f a b'.
--
-- instead me must rewrite to:
--
-- @
-- let a1 = f a b
-- in  h a1
-- @
caseCon' :: HasCallStack => NormRewrite
caseCon' :: NormRewrite
caseCon' ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
_) e :: Term
e@(Case Term
subj Kind
ty [Alt]
alts) = 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
Lens' RewriteEnv TyConMap
tcCache
 case Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
subj of
  -- The subject is an applied data constructor
  (Data DataCon
dc, [Either Term Kind]
args, [TickInfo]
ticks) -> case (Alt -> Bool) -> [Alt] -> Maybe Alt
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find (Pat -> Bool
equalCon (Pat -> Bool) -> (Alt -> Pat) -> Alt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Pat
forall a b. (a, b) -> a
fst) [Alt]
alts of
    Just (DataPat DataCon
_ [TyVar]
tvs [Var Term]
xs, Term
altE) -> do
     let
      -- Create the substitution environment for all the existential
      -- type variables.
      exTysList :: [(TyVar, Kind)]
exTysList = [TyVar] -> [Kind] -> [(TyVar, Kind)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [TyVar]
tvs (Int -> [Kind] -> [Kind]
forall a. Int -> [a] -> [a]
drop ([TyVar] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (DataCon -> [TyVar]
dcUnivTyVars DataCon
dc)) ([Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args))
      exTySubst :: Subst
exTySubst = Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is0) [(TyVar, Kind)]
exTysList
      -- Apply the type-substitution in all the pattern variables, we need
      -- to do this because we might use them as let-bindings later on,
      -- and they should have the correct type.
      xs1 :: [Var Term]
xs1 = (Var Term -> Var Term) -> [Var Term] -> [Var Term]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Var Term -> Var Term
forall a. HasCallStack => Subst -> Var a -> Var a
substTyInVar Subst
exTySubst) [Var Term]
xs
      -- Create an initial set of let-binders for all variables used in the
      -- RHS of the alternative. We might later decide to substitute instead
      -- of let-bind in case the RHS of the let-binder is work-free.
      fvs :: VarSet
fvs = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
altE
      ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs1 ([Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args)
      binds1 :: [LetBinding]
binds1 = (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks)) [LetBinding]
binds
     Term
altE1 <-
       case [LetBinding]
binds1 of
        [] ->
          -- Apply the type-substitution for the existential type variables
          Term -> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"caseCon1" Subst
exTySubst Term
altE)
        [LetBinding]
_  -> do
          -- See Note [CaseCon deshadow]
          let
            -- Only let-bind expression that perform work.
            is1 :: InScopeSet
is1 = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList (InScopeSet -> [TyVar] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [TyVar]
tvs) [Var Term]
xs1
          ((InScopeSet
is3,[LetBinding]
substIds),[Maybe LetBinding]
binds2) <- ((InScopeSet, [LetBinding])
 -> LetBinding
 -> RewriteMonad
      NormalizeState ((InScopeSet, [LetBinding]), Maybe LetBinding))
-> (InScopeSet, [LetBinding])
-> [LetBinding]
-> RewriteMonad
     NormalizeState ((InScopeSet, [LetBinding]), [Maybe LetBinding])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (InScopeSet, [LetBinding])
-> LetBinding
-> RewriteMonad
     NormalizeState ((InScopeSet, [LetBinding]), Maybe LetBinding)
forall extra (m :: Type -> Type).
MonadState (RewriteState extra) m =>
(InScopeSet, [LetBinding])
-> LetBinding -> m ((InScopeSet, [LetBinding]), Maybe LetBinding)
newBinder (InScopeSet
is1,[]) [LetBinding]
binds1
          let
            -- Create a substitution for all the existential type variables
            -- and the work-free expressions
            subst :: Subst
subst = Subst -> [LetBinding] -> Subst
extendIdSubstList
                      (Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is3) [(TyVar, Kind)]
exTysList)
                      [LetBinding]
substIds
            body :: Term
body  = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"caseCon1" Subst
subst Term
altE
          case [Maybe LetBinding] -> [LetBinding]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe LetBinding]
binds2 of
            []     -> Term -> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Term
body
            [LetBinding]
binds3 -> Term -> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds3 Term
body)
     Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE1
    Maybe Alt
_ -> case [Alt]
alts of
           -- In Core, default patterns always come first, so we match against
           -- that if there is one, and we couldn't match with any of the data
           -- patterns.
           ((Pat
DefaultPat,Term
altE):[Alt]
_) -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
           [Alt]
_ -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Kind -> Term
undefinedTm Kind
ty)
    where
      -- Check whether the pattern matches the data constructor
      equalCon :: Pat -> Bool
equalCon (DataPat DataCon
dcPat [TyVar]
_ [Var Term]
_) = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Int
dcTag DataCon
dcPat
      equalCon Pat
_                   = Bool
False

      -- Decide whether the applied arguments of the data constructor should
      -- be let-bound, or substituted into the alternative. We decide this
      -- based on the fact on whether the argument has the potential to make
      -- the circuit larger than needed if we were to duplicate that argument.
      newBinder :: (InScopeSet, [LetBinding])
-> LetBinding -> m ((InScopeSet, [LetBinding]), Maybe LetBinding)
newBinder (InScopeSet
isN0, [LetBinding]
substN) (Var Term
x, Term
arg) = do
        VarEnv (Binding Term)
bndrs <- Getting
  (VarEnv (Binding Term))
  (RewriteState extra)
  (VarEnv (Binding Term))
-> m (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 extra)
  (VarEnv (Binding Term))
forall extra. Lens' (RewriteState extra) (VarEnv (Binding Term))
bindings
        Lens' (RewriteState extra) (VarEnv Bool)
-> VarEnv (Binding Term) -> Term -> m Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState extra) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
arg m Bool
-> (Bool -> m ((InScopeSet, [LetBinding]), Maybe LetBinding))
-> m ((InScopeSet, [LetBinding]), Maybe LetBinding)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> ((InScopeSet, [LetBinding]), Maybe LetBinding)
-> m ((InScopeSet, [LetBinding]), Maybe LetBinding)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((InScopeSet
isN0, (Var Term
x, Term
arg)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
substN), Maybe LetBinding
forall a. Maybe a
Nothing)
          Bool
False ->
            let
              x' :: Var Term
x' = InScopeSet -> Var Term -> Var Term
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN0 Var Term
x
              isN1 :: InScopeSet
isN1 = InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isN0 Var Term
x'
            in
              ((InScopeSet, [LetBinding]), Maybe LetBinding)
-> m ((InScopeSet, [LetBinding]), Maybe LetBinding)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((InScopeSet
isN1, (Var Term
x, Var Term -> Term
Var Var Term
x')LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
substN), LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just (Var Term
x', Term
arg))


  -- The subject is a literal
  (Literal Literal
l,[Either Term Kind]
_,[TickInfo]
_) -> case (Alt -> Bool) -> [Alt] -> Maybe Alt
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find (Pat -> Bool
equalLit (Pat -> Bool) -> (Alt -> Pat) -> Alt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Pat
forall a b. (a, b) -> a
fst) [Alt]
alts of
    Just (LitPat Literal
_,Term
altE) -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
    Maybe Alt
_ -> Term -> Literal -> [Alt] -> RewriteMonad NormalizeState Term
matchLiteralContructor Term
e Literal
l [Alt]
alts
    where
      equalLit :: Pat -> Bool
equalLit (LitPat Literal
l')     = Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l'
      equalLit Pat
_               = Bool
False


  -- The subject is an applied primitive
  (Prim PrimInfo
_,[Either Term Kind]
_,[TickInfo]
_) ->
    -- We try to reduce the applied primitive to WHNF
    Bool
-> TransformContext
-> Term
-> NormRewrite
-> RewriteMonad NormalizeState Term
forall extra.
Bool
-> TransformContext
-> Term
-> Rewrite extra
-> RewriteMonad extra Term
whnfRW Bool
True TransformContext
ctx Term
subj (NormRewrite -> RewriteMonad NormalizeState Term)
-> NormRewrite -> RewriteMonad NormalizeState Term
forall a b. (a -> b) -> a -> b
$ \TransformContext
ctx1 Term
subj1 -> case Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
subj1 of
      -- WHNF of subject is a literal, try `caseCon` with that
      (Literal Literal
l,[Either Term Kind]
_,[TickInfo]
_) -> HasCallStack => NormRewrite
NormRewrite
caseCon TransformContext
ctx1 (Term -> Kind -> [Alt] -> Term
Case (Literal -> Term
Literal Literal
l) Kind
ty [Alt]
alts)
      -- WHNF of subject is a data-constructor, try `caseCon` with that
      (Data DataCon
_,[Either Term Kind]
_,[TickInfo]
_) -> HasCallStack => NormRewrite
NormRewrite
caseCon TransformContext
ctx1 (Term -> Kind -> [Alt] -> Term
Case Term
subj1 Kind
ty [Alt]
alts)
#if MIN_VERSION_ghc(8,2,2)
      -- WHNF of subject is _|_, in the form of `absentError`: that means that
      -- the entire case-expression is evaluates to _|_
      (Prim PrimInfo
pInfo,Either Term Kind
_:Either Term Kind
msgOrCallStack:[Either Term Kind]
_,[TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Control.Exception.Base.absentError" ->
        let e1 :: Term
e1 = Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (PrimInfo -> Term
Prim PrimInfo
pInfo) [TickInfo]
ticks)
                        [Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
ty,Either Term Kind
msgOrCallStack]
        in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
#endif
      -- WHNF of subject is _|_, in the form of `absentError`, `patError`,
      -- or `undefined`: that means the entire case-expression is _|_
      (Prim PrimInfo
pInfo,Either Term Kind
repTy:Either Term Kind
_:Either Term Kind
msgOrCallStack:[Either Term Kind]
_,[TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Text
"Control.Exception.Base.patError"
#if !MIN_VERSION_ghc(8,2,2)
                                ,"Control.Exception.Base.absentError"
#endif
                                ,Text
"GHC.Err.undefined"] ->
        let e1 :: Term
e1 = Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (PrimInfo -> Term
Prim PrimInfo
pInfo) [TickInfo]
ticks)
                        [Either Term Kind
repTy,Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
ty,Either Term Kind
msgOrCallStack]
        in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
      -- WHNF of subject is _|_, in the form of our internal _|_-values: that
      -- means the entire case-expression is _|_
      (Prim PrimInfo
pInfo,[Either Term Kind
_],[TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ Text
"Clash.Transformations.undefined"
                                , Text
"Clash.GHC.Evaluator.undefined"
                                , Text
"EmptyCase"] ->
        let e1 :: Term
e1 = Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (PrimInfo -> Term
Prim PrimInfo
pInfo) [TickInfo]
ticks) [Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
ty]
        in Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
      (Prim PrimInfo
pInfo,Either Term Kind
_:Either Term Kind
callStack:Either Term Kind
msg:[Either Term Kind]
_,[TickInfo]
_)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.XException.errorX"
        -> let e1 :: Term
e1 = Term -> [Either Term Kind] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo) [Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
ty,Either Term Kind
callStack,Either Term Kind
msg]
            in Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
      -- WHNF of subject is non of the above, so either a variable reference,
      -- or a primitive for which the evaluator doesn't have any evaluation
      -- rules.
      (Term, [Either Term Kind], [TickInfo])
_ -> do
        let subjTy :: Kind
subjTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
subj
        CustomReprs
-> TyConMap
-> Kind
-> State HWMap (Maybe (Either String FilteredHWType))
tran <- Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> RewriteMonad
     NormalizeState
     (CustomReprs
      -> TyConMap
      -> Kind
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  RewriteEnv
  (CustomReprs
   -> TyConMap
   -> Kind
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
        CustomReprs
reprs <- 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
Lens' RewriteEnv CustomReprs
customReprs
        case (State HWMap (Either String FilteredHWType)
-> HWMap -> Either String FilteredHWType
forall s a. State s a -> s -> a
`evalState` HWMap
forall k v. HashMap k v
HashMapS.empty) ((CustomReprs
 -> TyConMap
 -> Kind
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Kind
-> State HWMap (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Kind
-> State HWMap (Maybe (Either String FilteredHWType))
tran CustomReprs
reprs TyConMap
tcm Kind
subjTy) of
          Right (FilteredHWType (Void (Just HWType
hty)) [[(Bool, FilteredHWType)]]
_areVoids)
            | HWType
hty HWType -> [HWType] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [Int -> HWType
BitVector Int
0, Int -> HWType
Unsigned Int
0, Int -> HWType
Signed Int
0, Integer -> HWType
Index Integer
1]
            -- If we know that the type of the subject is zero-bits wide and
            -- one of the Clash number types. Then the only valid alternative is
            -- the one that can match on the literal "0", so try 'caseCon' with
            -- that.
            -> HasCallStack => NormRewrite
NormRewrite
caseCon TransformContext
ctx1 (Term -> Kind -> [Alt] -> Term
Case (Literal -> Term
Literal (Integer -> Literal
IntegerLiteral Integer
0)) Kind
ty [Alt]
alts)
          Either String FilteredHWType
_ -> do
            let ret :: RewriteMonad extra Term
ret = Term -> RewriteMonad extra Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt Term
e
            -- Otherwise check whether the entire case-expression has a single
            -- alternative, and pick that one.
            DebugLevel
lvl <- Getting DebugLevel RewriteEnv DebugLevel
-> RewriteMonad NormalizeState DebugLevel
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting DebugLevel RewriteEnv DebugLevel
Lens' RewriteEnv DebugLevel
dbgLevel
            if DebugLevel
lvl DebugLevel -> DebugLevel -> Bool
forall a. Ord a => a -> a -> Bool
> DebugLevel
DebugNone then do
              let subjIsConst :: Bool
subjIsConst = Term -> Bool
isConstant Term
subj
              -- In debug mode we always report missing evaluation rules for the
              -- primitive evaluator
              Bool
-> String
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. Bool -> String -> a -> a
traceIf (DebugLevel
lvl DebugLevel -> DebugLevel -> Bool
forall a. Ord a => a -> a -> Bool
> DebugLevel
DebugNone Bool -> Bool -> Bool
&& Bool
subjIsConst)
                      (String
"Irreducible constant as case subject: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
subj String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
"\nCan be reduced to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
subj1) RewriteMonad NormalizeState Term
forall extra. RewriteMonad extra Term
ret
            else
              RewriteMonad NormalizeState Term
forall extra. RewriteMonad extra Term
ret


  -- The subject is a variable
  (Var Var Term
v, [], [TickInfo]
_) | Kind -> Bool
isNum0 (Var Term -> Kind
forall a. Var a -> Kind
varType Var Term
v) ->
    -- If we know that the type of the subject is zero-bits wide and
    -- one of the Clash number types. Then the only valid alternative is
    -- the one that can match on the literal "0", so try 'caseCon' with
    -- that.
    HasCallStack => NormRewrite
NormRewrite
caseCon TransformContext
ctx (Term -> Kind -> [Alt] -> Term
Case (Literal -> Term
Literal (Integer -> Literal
IntegerLiteral Integer
0)) Kind
ty [Alt]
alts)
   where
    isNum0 :: Kind -> Bool
isNum0 (Kind -> TypeView
tyView -> TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
tcNm) [Kind
arg])
      | Text
tcNm Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem`
        [Text
"Clash.Sized.Internal.BitVector.BitVector"
        ,Text
"Clash.Sized.Internal.Unsigned.Unsigned"
        ,Text
"Clash.Sized.Internal.Signed.Signed"
        ]
      = Integer -> Kind -> Bool
isLitX Integer
0 Kind
arg
      | Text
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==
        Text
"Clash.Sized.Internal.Index.Index"
      = Integer -> Kind -> Bool
isLitX Integer
1 Kind
arg
    isNum0 (TyConMap -> Kind -> Maybe Kind
coreView1 TyConMap
tcm -> Just Kind
t) = Kind -> Bool
isNum0 Kind
t
    isNum0 Kind
_ = Bool
False

    isLitX :: Integer -> Kind -> Bool
isLitX Integer
n (LitTy (NumTy Integer
m)) = Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
m
    isLitX Integer
n (TyConMap -> Kind -> Maybe Kind
coreView1 TyConMap
tcm -> Just Kind
t) = Integer -> Kind -> Bool
isLitX Integer
n Kind
t
    isLitX Integer
_ Kind
_ = Bool
False

  -- Otherwise check whether the entire case-expression has a single
  -- alternative, and pick that one.
  (Term, [Either Term Kind], [TickInfo])
_ -> Term -> RewriteMonad NormalizeState Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt Term
e

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

{- [Note: Name re-creation]
The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding.
But only their uniqs end up in the heap, not the complete names.
So we use mkUnsafeSystemName to recreate the same Name.
-}

matchLiteralContructor
  :: Term
  -> Literal
  -> [(Pat,Term)]
  -> NormalizeSession Term
matchLiteralContructor :: Term -> Literal -> [Alt] -> RewriteMonad NormalizeState Term
matchLiteralContructor Term
c (IntegerLiteral Integer
l) [Alt]
alts = [Alt] -> RewriteMonad NormalizeState Term
forall extra. [Alt] -> RewriteMonad extra Term
go ([Alt] -> [Alt]
forall a. [a] -> [a]
reverse [Alt]
alts)
 where
  go :: [Alt] -> RewriteMonad extra Term
go [(Pat
DefaultPat,Term
e)] = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
  go ((DataPat DataCon
dc [] [Var Term]
xs,Term
e):[Alt]
alts')
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= ((-Integer
2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
63::Int)) Bool -> Bool -> Bool
&&  Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
63::Int)
    = let fvs :: VarSet
fvs       = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e
          ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs [Literal -> Term
Literal (Integer -> Literal
IntLiteral Integer
l)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 [LetBinding]
_  -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
e
      in Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e'
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
63::Int)
#if MIN_VERSION_base(4,15,0)
    = let !(IP ba) = l
#else
    = let !(Jp# !(BN# ByteArray#
ba)) = Integer
l
#endif
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          fvs :: VarSet
fvs       = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e
          ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs [Literal -> Term
Literal (ByteArray -> Literal
ByteArrayLiteral ByteArray
ba')]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 [LetBinding]
_  -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
e
      in Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e'
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< ((-Integer
2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
63::Int))
#if MIN_VERSION_base(4,15,0)
    = let !(IN ba) = l
#else
    = let !(Jn# !(BN# ByteArray#
ba)) = Integer
l
#endif
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          fvs :: VarSet
fvs       = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e
          ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs [Literal -> Term
Literal (ByteArray -> Literal
ByteArrayLiteral ByteArray
ba')]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 [LetBinding]
_  -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
e
      in Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e'
    | Bool
otherwise
    = [Alt] -> RewriteMonad extra Term
go [Alt]
alts'
  go ((LitPat Literal
l', Term
e):[Alt]
alts')
    | Integer -> Literal
IntegerLiteral Integer
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l'
    = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
    | Bool
otherwise
    = [Alt] -> RewriteMonad extra Term
go [Alt]
alts'
  go [Alt]
_ = String -> RewriteMonad extra Term
forall a. HasCallStack => String -> a
error (String -> RewriteMonad extra Term)
-> String -> RewriteMonad extra Term
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Report as bug: caseCon error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
c

matchLiteralContructor Term
c (NaturalLiteral Integer
l) [Alt]
alts = [Alt] -> RewriteMonad NormalizeState Term
forall extra. [Alt] -> RewriteMonad extra Term
go ([Alt] -> [Alt]
forall a. [a] -> [a]
reverse [Alt]
alts)
 where
  go :: [Alt] -> RewriteMonad extra Term
go [(Pat
DefaultPat,Term
e)] = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
  go ((DataPat DataCon
dc [] [Var Term]
xs,Term
e):[Alt]
alts')
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
64::Int)
    = let fvs :: VarSet
fvs       = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e
          ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs [Literal -> Term
Literal (Integer -> Literal
WordLiteral Integer
l)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 [LetBinding]
_  -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
e
      in Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e'
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
64::Int)
#if MIN_VERSION_base(4,15,0)
    = let !(IP ba) = l
#else
    = let !(Jp# !(BN# ByteArray#
ba)) = Integer
l
#endif
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          fvs :: VarSet
fvs       = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
unitVarSet Term
e
          ([LetBinding]
binds,[LetBinding]
_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
fvs) (Var Term -> Bool)
-> (LetBinding -> Var Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Var Term
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Var Term] -> [Term] -> [LetBinding]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
List.zipEqual [Var Term]
xs [Literal -> Term
Literal (ByteArray -> Literal
ByteArrayLiteral ByteArray
ba')]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 [LetBinding]
_  -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds Term
e
      in Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e'
    | Bool
otherwise
    = [Alt] -> RewriteMonad extra Term
go [Alt]
alts'
  go ((LitPat Literal
l', Term
e):[Alt]
alts')
    | Integer -> Literal
NaturalLiteral Integer
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l'
    = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
    | Bool
otherwise
    = [Alt] -> RewriteMonad extra Term
go [Alt]
alts'
  go [Alt]
_ = String -> RewriteMonad extra Term
forall a. HasCallStack => String -> a
error (String -> RewriteMonad extra Term)
-> String -> RewriteMonad extra Term
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Report as bug: caseCon error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
c

matchLiteralContructor Term
_ Literal
_ ((Pat
DefaultPat,Term
e):[Alt]
_) = Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
matchLiteralContructor Term
c Literal
_ [Alt]
_ =
  String -> RewriteMonad NormalizeState Term
forall a. HasCallStack => String -> a
error (String -> RewriteMonad NormalizeState Term)
-> String -> RewriteMonad NormalizeState Term
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Report as bug: caseCon error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
c
{-# SCC matchLiteralContructor #-}

caseOneAlt :: Term -> RewriteMonad extra Term
caseOneAlt :: Term -> RewriteMonad extra Term
caseOneAlt e :: Term
e@(Case Term
_ Kind
_ [(Pat
pat,Term
altE)]) = case Pat
pat of
  Pat
DefaultPat -> Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
  LitPat Literal
_ -> Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
  DataPat DataCon
_ [TyVar]
tvs [Var Term]
xs
    | ([TyVar] -> [Var Any]
coerce [TyVar]
tvs [Var Any] -> [Var Any] -> [Var Any]
forall a. [a] -> [a] -> [a]
++ [Var Term] -> [Var Any]
coerce [Var Term]
xs) [Var Any] -> Term -> Bool
forall a. [Var a] -> Term -> Bool
`localVarsDoNotOccurIn` Term
altE
    -> Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
    | Bool
otherwise
    -> Term -> RewriteMonad extra Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

caseOneAlt (Case Term
_ Kind
_ alts :: [Alt]
alts@((Pat
pat,Term
alt):Alt
_:[Alt]
_))
  | (Alt -> Bool) -> [Alt] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all ((Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
alt) (Term -> Bool) -> (Alt -> Term) -> Alt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Term
forall a b. (a, b) -> b
snd) ([Alt] -> [Alt]
forall a. [a] -> [a]
tail [Alt]
alts)
  , ([TyVar]
tvs,[Var Term]
xs) <- Pat -> ([TyVar], [Var Term])
patIds Pat
pat
  , ([TyVar] -> [Var Any]
coerce [TyVar]
tvs [Var Any] -> [Var Any] -> [Var Any]
forall a. [a] -> [a] -> [a]
++ [Var Term] -> [Var Any]
coerce [Var Term]
xs) [Var Any] -> Term -> Bool
forall a. [Var a] -> Term -> Bool
`localVarsDoNotOccurIn` Term
alt
  = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
alt

caseOneAlt Term
e = Term -> RewriteMonad extra Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC caseOneAlt #-}

-- | Bring an application of a DataCon or Primitive in ANF, when the argument is
-- is considered non-representable
nonRepANF :: HasCallStack => NormRewrite
nonRepANF :: NormRewrite
nonRepANF ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
_) e :: Term
e@(App Term
appConPrim Term
arg)
  | (Term
conPrim, [Either Term Kind]
_) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e
  , Term -> Bool
isCon Term
conPrim Bool -> Bool -> Bool
|| Term -> Bool
isPrim Term
conPrim
  = do
    Bool
untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
False Term
arg
    case (Bool
untranslatable,Term -> Term
stripTicks Term
arg) of
      (Bool
True,Letrec [LetBinding]
binds Term
body) ->
        -- This is a situation similar to Note [CaseLet deshadow]
        let ([LetBinding]
binds1,Term
body1) = HasCallStack =>
InScopeSet -> [LetBinding] -> Term -> ([LetBinding], Term)
InScopeSet -> [LetBinding] -> Term -> ([LetBinding], Term)
deshadowLetExpr InScopeSet
is0 [LetBinding]
binds Term
body
        in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds1 (Term -> Term -> Term
App Term
appConPrim Term
body1))
      (Bool
True,Case {})  -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      (Bool
True,Lam {})   -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      (Bool
True,TyLam {}) -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      (Bool, Term)
_               -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

-- | Ensure that top-level lambda's eventually bind a let-expression of which
-- the body is a variable-reference.
topLet :: HasCallStack => NormRewrite
topLet :: NormRewrite
topLet (TransformContext InScopeSet
is0 Context
ctx) Term
e
  | (CoreContext -> Bool) -> Context -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\CoreContext
c -> CoreContext -> Bool
isLambdaBodyCtx CoreContext
c Bool -> Bool -> Bool
|| CoreContext -> Bool
isTickCtx CoreContext
c) Context
ctx Bool -> Bool -> Bool
&& Bool -> Bool
not (Term -> Bool
isLet Term
e) Bool -> Bool -> Bool
&& Bool -> Bool
not (Term -> Bool
isTick Term
e)
  = do
  Bool
untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
False Term
e
  if Bool
untranslatable
    then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    else 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
Lens' RewriteEnv TyConMap
tcCache
            Var Term
argId <- InScopeSet
-> TyConMap
-> Name Any
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is0 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"result" Int
0) Term
e
            Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec [(Var Term
argId, Term
e)] (Var Term -> Term
Var Var Term
argId))
 where
  isTick :: Term -> Bool
isTick Tick{} = Bool
True
  isTick Term
_ = Bool
False

topLet (TransformContext InScopeSet
is0 Context
ctx) e :: Term
e@(Letrec [LetBinding]
binds Term
body)
  | (CoreContext -> Bool) -> Context -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\CoreContext
c -> CoreContext -> Bool
isLambdaBodyCtx CoreContext
c Bool -> Bool -> Bool
|| CoreContext -> Bool
isTickCtx CoreContext
c) Context
ctx
  = do
    let localVar :: Bool
localVar = Term -> Bool
isLocalVar Term
body
    Bool
untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
False Term
body
    if Bool
localVar Bool -> Bool -> Bool
|| Bool
untranslatable
      then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      else 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
Lens' RewriteEnv TyConMap
tcCache
        let is2 :: InScopeSet
is2 = 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)
        Var Term
argId <- InScopeSet
-> TyConMap
-> Name Any
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is2 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"result" Int
0) Term
body
        Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec ([LetBinding]
binds [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Var Term
argId,Term
body)]) (Var Term -> Term
Var Var Term
argId))

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

-- Misc rewrites

-- | Remove unused let-bindings
deadCode :: HasCallStack => NormRewrite
deadCode :: NormRewrite
deadCode TransformContext
_ e :: Term
e@(Letrec [LetBinding]
binds Term
body) =
  case [LetBinding] -> Term -> Maybe Term
removeUnusedBinders [LetBinding]
binds Term
body of
    Just Term
t -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
t
    Maybe Term
Nothing -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
deadCode TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC deadCode #-}

removeUnusedExpr :: HasCallStack => NormRewrite
removeUnusedExpr :: NormRewrite
removeUnusedExpr TransformContext
_ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (p :: Term
p@(Prim PrimInfo
pInfo),[Either Term Kind]
args,[TickInfo]
ticks)) = do
  Maybe GuardedCompiledPrimitive
bbM <- Text
-> HashMap Text GuardedCompiledPrimitive
-> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (PrimInfo -> Text
primName PrimInfo
pInfo) (HashMap Text GuardedCompiledPrimitive
 -> Maybe GuardedCompiledPrimitive)
-> RewriteMonad
     NormalizeState (HashMap Text GuardedCompiledPrimitive)
-> RewriteMonad NormalizeState (Maybe GuardedCompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (HashMap Text GuardedCompiledPrimitive)
  (RewriteState NormalizeState)
  (HashMap Text GuardedCompiledPrimitive)
-> RewriteMonad
     NormalizeState (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState
 -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
-> RewriteState NormalizeState
-> Const
     (HashMap Text GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState
  -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
 -> RewriteState NormalizeState
 -> Const
      (HashMap Text GuardedCompiledPrimitive)
      (RewriteState NormalizeState))
-> ((HashMap Text GuardedCompiledPrimitive
     -> Const
          (HashMap Text GuardedCompiledPrimitive)
          (HashMap Text GuardedCompiledPrimitive))
    -> NormalizeState
    -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
-> Getting
     (HashMap Text GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
     (HashMap Text GuardedCompiledPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(HashMap Text GuardedCompiledPrimitive
 -> Const
      (HashMap Text GuardedCompiledPrimitive)
      (HashMap Text GuardedCompiledPrimitive))
-> NormalizeState
-> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState
Lens' NormalizeState (HashMap Text GuardedCompiledPrimitive)
primitives)
  let
    usedArgs0 :: Maybe [Int]
usedArgs0 =
      case Maybe (Maybe CompiledPrimitive) -> Maybe CompiledPrimitive
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
Monad.join (GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim (GuardedCompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe GuardedCompiledPrimitive
-> Maybe (Maybe CompiledPrimitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe GuardedCompiledPrimitive
bbM) of
        Just (BlackBoxHaskell{UsedArguments
usedArguments :: forall a b c d. Primitive a b c d -> UsedArguments
usedArguments :: UsedArguments
usedArguments}) ->
          case UsedArguments
usedArguments of
            UsedArguments [Int]
used -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
used
            IgnoredArguments [Int]
ignored -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int
0..[Either Term Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Kind]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
ignored)
        Just (BlackBox Text
pNm WorkInfo
_ RenderVoid
_ Bool
_ TemplateKind
_ ()
_ Bool
_ [BlackBoxTemplate]
_ [BlackBoxTemplate]
_ [(Int, Int)]
_ [((Text, Text), BlackBox)]
inc [BlackBox]
r [BlackBox]
ri BlackBox
templ) -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$
          if | Text -> Bool
isFromInt Text
pNm -> [Int
0,Int
1,Int
2]
             | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ Text
"Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"
                                     , Text
"Clash.Sized.Vector.splitAt"
                                     ] -> [Int
0,Int
1]
             | Bool
otherwise -> [[Int]] -> [Int]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ (BlackBox -> [Int]) -> [BlackBox] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap BlackBox -> [Int]
getUsedArguments [BlackBox]
r
                                   , (BlackBox -> [Int]) -> [BlackBox] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap BlackBox -> [Int]
getUsedArguments [BlackBox]
ri
                                   , BlackBox -> [Int]
getUsedArguments BlackBox
templ
                                   , (((Text, Text), BlackBox) -> [Int])
-> [((Text, Text), BlackBox)] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (BlackBox -> [Int]
getUsedArguments (BlackBox -> [Int])
-> (((Text, Text), BlackBox) -> BlackBox)
-> ((Text, Text), BlackBox)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), BlackBox) -> BlackBox
forall a b. (a, b) -> b
snd) [((Text, Text), BlackBox)]
inc ]
        Maybe CompiledPrimitive
_ ->
          Maybe [Int]
forall a. Maybe a
Nothing

  case Maybe [Int]
usedArgs0 of
    Maybe [Int]
Nothing ->
      Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    Just [Int]
usedArgs1 -> 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
Lens' RewriteEnv TyConMap
tcCache
      ([Either Term Kind]
args1, Any -> Bool
Monoid.getAny -> Bool
hasChanged) <- RewriteMonad NormalizeState [Either Term Kind]
-> RewriteMonad NormalizeState ([Either Term Kind], Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen (TyConMap
-> Int
-> [Int]
-> [Either Term Kind]
-> RewriteMonad NormalizeState [Either Term Kind]
forall (t :: Type -> Type) b extra.
Foldable t =>
TyConMap
-> Int
-> t Int
-> [Either Term b]
-> RewriteMonad extra [Either Term b]
go TyConMap
tcm Int
0 [Int]
usedArgs1 [Either Term Kind]
args)
      if Bool
hasChanged then
        Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks Term
p [TickInfo]
ticks) [Either Term Kind]
args1)
      else
        Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

  where
    arity :: Int
arity = [Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([Kind] -> Int)
-> (([Either TyVar Kind], Kind) -> [Kind])
-> ([Either TyVar Kind], Kind)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either TyVar Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights ([Either TyVar Kind] -> [Kind])
-> (([Either TyVar Kind], Kind) -> [Either TyVar Kind])
-> ([Either TyVar Kind], Kind)
-> [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Either TyVar Kind], Kind) -> [Either TyVar Kind]
forall a b. (a, b) -> a
fst (([Either TyVar Kind], Kind) -> Int)
-> ([Either TyVar Kind], Kind) -> Int
forall a b. (a -> b) -> a -> b
$ Kind -> ([Either TyVar Kind], Kind)
splitFunForallTy (PrimInfo -> Kind
primType PrimInfo
pInfo)

    go :: TyConMap
-> Int
-> t Int
-> [Either Term b]
-> RewriteMonad extra [Either Term b]
go TyConMap
_ Int
_ t Int
_ [] = [Either Term b] -> RewriteMonad extra [Either Term b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
    go TyConMap
tcm !Int
n t Int
used (Right b
ty:[Either Term b]
args') = do
      [Either Term b]
args'' <- TyConMap
-> Int
-> t Int
-> [Either Term b]
-> RewriteMonad extra [Either Term b]
go TyConMap
tcm Int
n t Int
used [Either Term b]
args'
      [Either Term b] -> RewriteMonad extra [Either Term b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (b -> Either Term b
forall a b. b -> Either a b
Right b
ty Either Term b -> [Either Term b] -> [Either Term b]
forall a. a -> [a] -> [a]
: [Either Term b]
args'')
    go TyConMap
tcm !Int
n t Int
used (Left Term
tm : [Either Term b]
args') = do
      [Either Term b]
args'' <- TyConMap
-> Int
-> t Int
-> [Either Term b]
-> RewriteMonad extra [Either Term b]
go TyConMap
tcm (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) t Int
used [Either Term b]
args'
      case Term
tm of
        TyApp (Prim PrimInfo
p0) Kind
_
          | PrimInfo -> Text
primName PrimInfo
p0 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Transformations.removedArg"
          -> [Either Term b] -> RewriteMonad extra [Either Term b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Either Term b
forall a b. a -> Either a b
Left Term
tm Either Term b -> [Either Term b] -> [Either Term b]
forall a. a -> [a] -> [a]
: [Either Term b]
args'')
        Term
_ -> do
          let ty :: Kind
ty = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
tm
              p' :: Term
p' = Kind -> Term
removedTm Kind
ty
          if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arity Bool -> Bool -> Bool
&& Int
n Int -> t Int -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` t Int
used
             then [Either Term b] -> RewriteMonad extra [Either Term b]
forall a extra. a -> RewriteMonad extra a
changed (Term -> Either Term b
forall a b. a -> Either a b
Left Term
p' Either Term b -> [Either Term b] -> [Either Term b]
forall a. a -> [a] -> [a]
: [Either Term b]
args'')
             else [Either Term b] -> RewriteMonad extra [Either Term b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return  (Term -> Either Term b
forall a b. a -> Either a b
Left Term
tm Either Term b -> [Either Term b] -> [Either Term b]
forall a. a -> [a] -> [a]
: [Either Term b]
args'')

removeUnusedExpr TransformContext
_ e :: Term
e@(Case Term
_ Kind
_ [(DataPat DataCon
_ [] [Var Term]
xs,Term
altExpr)]) =
  if [Var Term]
xs [Var Term] -> Term -> Bool
`localIdsDoNotOccurIn` Term
altExpr
     then Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altExpr
     else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

-- Replace any expression that creates a Vector of size 0 within the application
-- of the Cons constructor, by the Nil constructor.
removeUnusedExpr TransformContext
_ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Data DataCon
dc, [Either Term Kind
_,Right Kind
aTy,Right Kind
nTy,Either Term Kind
_,Left Term
a,Left Term
nil],[TickInfo]
ticks))
  | Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Vector.Cons"
  = 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
Lens' RewriteEnv TyConMap
tcCache
    case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
      Right Integer
0
        | (Term
con, [Either Term Kind]
_) <- Term -> (Term, [Either Term Kind])
collectArgs Term
nil
        , Bool -> Bool
not (Term -> Bool
isCon Term
con)
        -> let eTy :: Kind
eTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e
               (TyConApp TyConName
vecTcNm [Kind]
_) = Kind -> TypeView
tyView Kind
eTy
               (Just TyCon
vecTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
vecTcNm TyConMap
tcm
               [DataCon
nilCon,DataCon
consCon] = TyCon -> [DataCon]
tyConDataCons TyCon
vecTc
               v :: Term
v = Term -> [TickInfo] -> Term
mkTicks (DataCon -> DataCon -> Kind -> Integer -> [Term] -> Term
mkVec DataCon
nilCon DataCon
consCon Kind
aTy Integer
1 [Term
a]) [TickInfo]
ticks
           in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
v
      Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

-- | 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,
 MonadState (RewriteState NormalizeState) 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
`localIdDoesNotOccurIn` 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
Lens' RewriteEnv TyConMap
tcCache
        case TyConMap -> Term -> Bool
isWorkFreeIsh TyConMap
tcm Term
e of
          Bool
True -> Getting Word (RewriteState NormalizeState) Word -> m Word
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Word NormalizeState)
-> RewriteState NormalizeState
-> Const Word (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Word NormalizeState)
 -> RewriteState NormalizeState
 -> Const Word (RewriteState NormalizeState))
-> ((Word -> Const Word Word)
    -> NormalizeState -> Const Word NormalizeState)
-> Getting Word (RewriteState NormalizeState) Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Word -> Const Word Word)
-> NormalizeState -> Const Word NormalizeState
Lens' NormalizeState 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 #-}

-- | Push a cast over a case into it's alternatives.
caseCast :: HasCallStack => NormRewrite
caseCast :: NormRewrite
caseCast TransformContext
_ (Cast (Term -> Term
stripTicks -> Case Term
subj Kind
ty [Alt]
alts) Kind
ty1 Kind
ty2) = do
  let alts' :: [Alt]
alts' = (Alt -> Alt) -> [Alt] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pat
p,Term
e) -> (Pat
p, Term -> Kind -> Kind -> Term
Cast Term
e Kind
ty1 Kind
ty2)) [Alt]
alts
  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> Kind -> [Alt] -> Term
Case Term
subj Kind
ty [Alt]
alts')
caseCast TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC caseCast #-}


-- | Push a cast over a Letrec into it's body
letCast :: HasCallStack => NormRewrite
letCast :: NormRewrite
letCast TransformContext
_ (Cast (Term -> Term
stripTicks -> Letrec [LetBinding]
binds Term
body) Kind
ty1 Kind
ty2) =
  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
$ [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds (Term -> Kind -> Kind -> Term
Cast Term
body Kind
ty1 Kind
ty2)
letCast TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC letCast #-}


-- | Push cast over an argument to a function into that function
--
-- This is done by specializing on the casted argument.
-- Example:
-- @
--   y = f (cast a)
--     where f x = g x
-- @
-- transforms to:
-- @
--   y = f' a
--     where f' x' = (\x -> g x) (cast x')
-- @
--
-- The reason d'etre for this transformation is that we hope to end up with
-- and expression where two casts are "back-to-back" after which we can
-- eliminate them in 'eliminateCastCast'.
argCastSpec :: HasCallStack => NormRewrite
argCastSpec :: NormRewrite
argCastSpec TransformContext
ctx e :: Term
e@(App Term
f (Term -> Term
stripTicks -> Cast Term
e' Kind
_ Kind
_))
 -- Don't specialise when the arguments are casts-of-casts, these casts-of-casts
 -- will be eliminated by 'eliminateCastCast' during the normalization of the
 -- "current" function. We thus prevent the unnecessary introduction of a
 -- specialized version of 'f'.
 | Bool -> Bool
not (Term -> Bool
isCast Term
e)
 -- Don't specialise prims, because we can't push casts into them
 , Bool -> Bool
not (Bool -> Bool) -> (Term -> Bool) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Bool
isPrim (Term -> Bool) -> (Term -> Term) -> Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, [Either Term Kind]) -> Term
forall a b. (a, b) -> a
fst ((Term, [Either Term Kind]) -> Term)
-> (Term -> (Term, [Either Term Kind])) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> (Term, [Either Term Kind])
collectArgs (Term -> Bool) -> Term -> Bool
forall a b. (a -> b) -> a -> b
$ Term
f = 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
  Lens' (RewriteState NormalizeState) (VarEnv Bool)
-> VarEnv (Binding Term)
-> Term
-> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState NormalizeState) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
e' RewriteMonad NormalizeState Bool
-> (Bool -> RewriteMonad NormalizeState Term)
-> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> RewriteMonad NormalizeState Term
go
    Bool
False -> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. a -> a
warn RewriteMonad NormalizeState Term
go
 where
  go :: RewriteMonad NormalizeState Term
go = NormRewrite
specializeNorm TransformContext
ctx Term
e
  warn :: a -> a
warn = String -> a -> a
forall a. String -> a -> a
trace ([String] -> String
unwords
    [ String
"WARNING:", $(String
curLoc), String
"specializing a function on a non work-free"
    , String
"cast. Generated HDL implementation might contain duplicate work."
    , String
"Please report this as a bug.", String
"\n\nExpression where this occured:"
    , String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
    ])
argCastSpec TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC argCastSpec #-}

-- | 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 {}) Kind
_ Kind
_)) = 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 #-}

-- | Eliminate two back to back casts where the type going in and coming out are the same
--
-- @
--   (cast :: b -> a) $ (cast :: a -> b) x   ==> x
-- @
eliminateCastCast :: HasCallStack => NormRewrite
eliminateCastCast :: NormRewrite
eliminateCastCast TransformContext
_ c :: Term
c@(Cast (Term -> Term
stripTicks -> Cast Term
e Kind
tyA Kind
tyB) Kind
tyB' Kind
tyC) = 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
Lens' RewriteEnv TyConMap
tcCache
  let ntyA :: Kind
ntyA  = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm Kind
tyA
      ntyB :: Kind
ntyB  = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm Kind
tyB
      ntyB' :: Kind
ntyB' = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm Kind
tyB'
      ntyC :: Kind
ntyC  = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm Kind
tyC
  if Kind
ntyB Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
ntyB' Bool -> Bool -> Bool
&& Kind
ntyA Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
ntyC then Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
                                   else RewriteMonad NormalizeState Term
forall b. RewriteMonad NormalizeState b
throwError
  where throwError :: RewriteMonad NormalizeState b
throwError = do
          (Var Term
nm,SrcSpan
sp) <- 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
          ClashException -> RewriteMonad NormalizeState b
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var Term -> String
forall p. PrettyPrec p => p -> String
showPpr Var Term
nm
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Found 2 nested casts whose types don't line up:\n"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
c)
                Maybe String
forall a. Maybe a
Nothing)

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

-- | Make a cast work-free by splitting the work of to a separate binding
--
-- @
-- let x = cast (f a b)
-- ==>
-- let x  = cast x'
--     x' = f a b
-- @
splitCastWork :: HasCallStack => NormRewrite
splitCastWork :: NormRewrite
splitCastWork ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
_) unchanged :: Term
unchanged@(Letrec [LetBinding]
vs Term
e') = do
  ([[LetBinding]]
vss', Any -> Bool
Monoid.getAny -> Bool
hasChanged) <- RewriteMonad NormalizeState [[LetBinding]]
-> RewriteMonad NormalizeState ([[LetBinding]], Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen ((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 (InScopeSet
-> LetBinding -> RewriteMonad NormalizeState [LetBinding]
forall extra.
InScopeSet -> LetBinding -> RewriteMonad extra [LetBinding]
splitCastLetBinding InScopeSet
is0) [LetBinding]
vs)
  let vs' :: [LetBinding]
vs' = [[LetBinding]] -> [LetBinding]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[LetBinding]]
vss'
  if Bool
hasChanged then Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec [LetBinding]
vs' Term
e')
                else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
unchanged
  where
    splitCastLetBinding
      :: InScopeSet
      -> LetBinding
      -> RewriteMonad extra [LetBinding]
    splitCastLetBinding :: InScopeSet -> LetBinding -> RewriteMonad extra [LetBinding]
splitCastLetBinding InScopeSet
isN x :: LetBinding
x@(Var Term
nm, Term
e) = case Term -> Term
stripTicks Term
e of
      Cast (Var {}) Kind
_ Kind
_  -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]  -- already work-free
      Cast (Cast {}) Kind
_ Kind
_ -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]  -- casts will be eliminated
      Cast Term
e0 Kind
ty1 Kind
ty2 -> do
        TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap -> RewriteMonad extra TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
        Var Term
nm' <- InScopeSet
-> TyConMap -> Name Term -> Term -> RewriteMonad extra (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
isN TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx (Name Term -> Text
forall a. Name a -> Text
nameOcc (Name Term -> Text) -> Name Term -> Text
forall a b. (a -> b) -> a -> b
$ Var Term -> Name Term
forall a. Var a -> Name a
varName Var Term
nm)) Term
e0
        [LetBinding] -> RewriteMonad extra [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed [(Var Term
nm',Term
e0)
                ,(Var Term
nm, Term -> Kind -> Kind -> Term
Cast (Var Term -> Term
Var Var Term
nm') Kind
ty1 Kind
ty2)
                ]
      Term
_ -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]

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


-- | 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 Kind], [TickInfo])
collectArgsTicks -> (Var Var Term
f,args :: [Either Term Kind]
args@(Either Term Kind
_:[Either Term Kind]
_),[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
Lens' RewriteEnv TyConMap
tcCache
    let eTy :: Kind
eTy = TyConMap -> Term -> Kind
termType 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 Kind -> RewriteMonad NormalizeState Bool)
-> [Either Term Kind] -> 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)
-> (Kind -> RewriteMonad NormalizeState Bool)
-> Either Term Kind
-> 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
-> Kind -> 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 Kind]
args
    Bool
untranslatable <- Bool -> Kind -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Kind -> RewriteMonad extra Bool
isUntranslatableType Bool
True Kind
eTy
    VarSet
topEnts <- Getting VarSet RewriteEnv VarSet
-> RewriteMonad NormalizeState VarSet
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting VarSet RewriteEnv VarSet
Lens' RewriteEnv VarSet
topEntities
    let isSignal :: Bool
isSignal = TyConMap -> Kind -> Bool
isSignalType TyConMap
tcm Kind
eTy
    let lv :: Bool
lv = Var Term -> Bool
forall a. Var a -> Bool
isLocalId Var Term
f
    let isTopEnt :: Bool
isTopEnt = Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
elemVarSet Var Term
f VarSet
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 Kind] -> Term
mkApps Term
tm [Either Term Kind]
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
Lens' RewriteEnv TyConMap
tcCache
      let e'Ty :: Kind
e'Ty     = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e'
          isSignal :: Bool
isSignal = TyConMap -> Kind -> Bool
isSignalType TyConMap
tcm Kind
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
Lens' RewriteEnv TyConMap
tcCache
  let fTy :: Kind
fTy      = Var Term -> Kind
forall a. Var a -> Kind
varType Var Term
f
      closed :: Bool
closed   = Bool -> Bool
not (TyConMap -> Kind -> Bool
isPolyFunCoreTy TyConMap
tcm Kind
fTy)
      isSignal :: Bool
isSignal = TyConMap -> Kind -> Bool
isSignalType TyConMap
tcm Kind
fTy
  Bool
untranslatable <- Bool -> Kind -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Kind -> RewriteMonad extra Bool
isUntranslatableType Bool
True Kind
fTy
  VarSet
topEnts <- Getting VarSet RewriteEnv VarSet
-> RewriteMonad NormalizeState VarSet
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting VarSet RewriteEnv VarSet
Lens' RewriteEnv VarSet
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 -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`notElemVarSet` VarSet
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 (RewriteState NormalizeState) Word
-> RewriteMonad NormalizeState Word
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Word NormalizeState)
-> RewriteState NormalizeState
-> Const Word (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Word NormalizeState)
 -> RewriteState NormalizeState
 -> Const Word (RewriteState NormalizeState))
-> ((Word -> Const Word Word)
    -> NormalizeState -> Const Word NormalizeState)
-> Getting Word (RewriteState NormalizeState) Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Word -> Const Word Word)
-> NormalizeState -> Const Word NormalizeState
Lens' NormalizeState 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 #-}

-- | Inline small functions
inlineSmall :: HasCallStack => NormRewrite
inlineSmall :: NormRewrite
inlineSmall TransformContext
_ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Var Var Term
f,[Either Term Kind]
args,[TickInfo]
ticks)) = do
  Bool
untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
True Term
e
  VarSet
topEnts <- Getting VarSet RewriteEnv VarSet
-> RewriteMonad NormalizeState VarSet
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting VarSet RewriteEnv VarSet
Lens' RewriteEnv VarSet
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 -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
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 (RewriteState NormalizeState) Word
-> RewriteMonad NormalizeState Word
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Word NormalizeState)
-> RewriteState NormalizeState
-> Const Word (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Word NormalizeState)
 -> RewriteState NormalizeState
 -> Const Word (RewriteState NormalizeState))
-> ((Word -> Const Word Word)
    -> NormalizeState -> Const Word NormalizeState)
-> Getting Word (RewriteState NormalizeState) Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Word -> Const Word Word)
-> NormalizeState -> Const Word NormalizeState
Lens' NormalizeState 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 Kind] -> Term
mkApps Term
tm [Either Term Kind]
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 #-}

-- | Specialise functions on arguments which are constant, except when they
-- are clock, reset generators.
constantSpec :: HasCallStack => NormRewrite
constantSpec :: NormRewrite
constantSpec ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
tfCtx) e :: Term
e@(App Term
e1 Term
e2)
  | (Var {}, [Either Term Kind]
args) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e1
  , ([Term]
_, []) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
  , [TyVar] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting (Endo [TyVar]) Term TyVar -> Term -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Term TyVar
Fold Term TyVar
termFreeTyVars Term
e2
  = do ConstantSpecInfo
specInfo<- TransformContext
-> Term -> RewriteMonad NormalizeState ConstantSpecInfo
constantSpecInfo TransformContext
ctx Term
e2
       if ConstantSpecInfo -> Bool
csrFoundConstant ConstantSpecInfo
specInfo then
         let newBindings :: [LetBinding]
newBindings = ConstantSpecInfo -> [LetBinding]
csrNewBindings ConstantSpecInfo
specInfo in
         if [LetBinding] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [LetBinding]
newBindings then
           -- Whole of e2 is constant
           NormRewrite
specializeNorm TransformContext
ctx (Term -> Term -> Term
App Term
e1 Term
e2)
         else do
           -- Parts of e2 are constant
           let is1 :: InScopeSet
is1 = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 (LetBinding -> Var Term
forall a b. (a, b) -> a
fst (LetBinding -> Var Term) -> [LetBinding] -> [Var Term]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstantSpecInfo -> [LetBinding]
csrNewBindings ConstantSpecInfo
specInfo)
           [LetBinding] -> Term -> Term
Letrec [LetBinding]
newBindings
            (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NormRewrite
specializeNorm
                  (InScopeSet -> Context -> TransformContext
TransformContext InScopeSet
is1 Context
tfCtx)
                  (Term -> Term -> Term
App Term
e1 (ConstantSpecInfo -> Term
csrNewTerm ConstantSpecInfo
specInfo))

       else
        -- e2 has no constant parts
        Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
constantSpec TransformContext
_ Term
e = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC constantSpec #-}


-- Experimental

-- | Propagate arguments of application inwards; except for 'Lam' where the
-- argument becomes let-bound. 'appPropFast' tries to propagate as many arguments
-- as possible, down as many levels as possible; and should be called in a
-- top-down traversal.
--
-- The idea is that this reduces the number of traversals, which hopefully leads
-- to shorter compile times.
--
-- Note [AppProp no shadowing]
--
-- Case 1.
--
-- Imagine:
--
-- @
-- (case x of
--    D a b -> h a) (f x y)
-- @
--
-- rewriting this to:
--
-- @
-- let b = f x y
-- in  case x of
--       D a b -> h a b
-- @
--
-- is very bad because 'b' in 'h a b' is now bound by the pattern instead of the
-- newly introduced let-binding
--
-- instead me must deshadow w.r.t. the new variable and rewrite to:
--
-- @
-- let b = f x y
-- in  case x of
--       D a b1 -> h a b
-- @
--
-- Case 2.
--
-- Imagine
--
-- @
-- (\x -> e) u
-- @
--
-- where @u@ has a free variable named @x@, rewriting this to:
--
-- @
-- let x = u
-- in  e
-- @
--
-- would be very bad, because the let-binding suddenly captures the free
-- variable in @u@. To prevent this from happening we over-approximate and check
-- whether @x@ is in the current InScopeSet, and deshadow if that's the case,
-- i.e. we then rewrite to:
--
-- let x1 = u
-- in  e [x:=x1]
--
-- Case 3.
--
-- The same for:
--
-- @
-- (let x = w in e) u
-- @
--
-- where @u@ again has a free variable @x@, rewriting this to:
--
-- @
-- let x = w in (e u)
-- @
--
-- would be bad because the let-binding now captures the free variable in @u@.
--
-- To prevent this from happening, we unconditionally deshadow the function part
-- of the application w.r.t. the free variables in the argument part of the
-- application. It is okay to over-approximate in this case and deshadow w.r.t
-- the current InScopeSet.
appPropFast :: HasCallStack => NormRewrite
appPropFast :: NormRewrite
appPropFast ctx :: TransformContext
ctx@(TransformContext InScopeSet
is Context
_) = \case
  e :: Term
e@App {}
    | let (Term
fun,[Either Term Kind]
args,[TickInfo]
ticks) = Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
e
    -> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is (HasCallStack => InScopeSet -> Term -> Term
InScopeSet -> Term -> Term
deShadowTerm InScopeSet
is Term
fun) [Either Term Kind]
args [TickInfo]
ticks
  e :: Term
e@TyApp {}
    | let (Term
fun,[Either Term Kind]
args,[TickInfo]
ticks) = Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
e
    -> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is (HasCallStack => InScopeSet -> Term -> Term
InScopeSet -> Term -> Term
deShadowTerm InScopeSet
is Term
fun) [Either Term Kind]
args [TickInfo]
ticks
  Term
e          -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
 where
  go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo]
     -> NormalizeSession Term
  go :: InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is0 (Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Term
fun,args0 :: [Either Term Kind]
args0@(Either Term Kind
_:[Either Term Kind]
_),[TickInfo]
ticks0)) [Either Term Kind]
args1 [TickInfo]
ticks1 =
    InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is0 Term
fun ([Either Term Kind]
args0 [Either Term Kind] -> [Either Term Kind] -> [Either Term Kind]
forall a. [a] -> [a] -> [a]
++ [Either Term Kind]
args1) ([TickInfo]
ticks0 [TickInfo] -> [TickInfo] -> [TickInfo]
forall a. [a] -> [a] -> [a]
++ [TickInfo]
ticks1)

  go InScopeSet
is0 (Lam Var Term
v Term
e) (Left Term
arg:[Either Term Kind]
args) [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    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
    [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term -> Bool
isVar Term
arg), Lens' (RewriteState NormalizeState) (VarEnv Bool)
-> VarEnv (Binding Term)
-> Term
-> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState NormalizeState) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
arg] RewriteMonad NormalizeState Bool
-> (Bool -> RewriteMonad NormalizeState Term)
-> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True ->
        let subst :: Subst
subst = Subst -> Var Term -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Var Term
v Term
arg in
        (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is0 (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"appPropFast.AppLam" Subst
subst Term
e) [Either Term Kind]
args []
      Bool
False ->
        let is1 :: InScopeSet
is1 = InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Var Term
v in
        [LetBinding] -> Term -> Term
Letrec [(Var Term
v, Term
arg)] (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is1 (HasCallStack => InScopeSet -> Term -> Term
InScopeSet -> Term -> Term
deShadowTerm InScopeSet
is1 Term
e) [Either Term Kind]
args [TickInfo]
ticks

  go InScopeSet
is0 (Letrec [LetBinding]
vs Term
e) args :: [Either Term Kind]
args@(Either Term Kind
_:[Either Term Kind]
_) [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    let vbs :: [Var Term]
vbs  = (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]
vs
        is1 :: InScopeSet
is1  = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Var Term]
vbs
    -- XXX: 'vs' should already be deshadowed w.r.t. 'is0'
    [LetBinding] -> Term -> Term
Letrec [LetBinding]
vs (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is1 Term
e [Either Term Kind]
args [TickInfo]
ticks

  go InScopeSet
is0 (TyLam TyVar
tv Term
e) (Right Kind
t:[Either Term Kind]
args) [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    let subst :: Subst
subst = Subst -> TyVar -> Kind -> Subst
extendTvSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) TyVar
tv Kind
t
    (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is0 (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"appPropFast.TyAppTyLam" Subst
subst Term
e) [Either Term Kind]
args []

  go InScopeSet
is0 (Case Term
scrut Kind
ty0 [Alt]
alts) args0 :: [Either Term Kind]
args0@(Either Term Kind
_:[Either Term Kind]
_) [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    let isA1 :: InScopeSet
isA1 = InScopeSet -> InScopeSet -> InScopeSet
unionInScope
                 InScopeSet
is0
                 ((VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> ([Alt] -> VarSet) -> [Alt] -> InScopeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Var Any] -> VarSet
forall a. [Var a] -> VarSet
mkVarSet ([Var Any] -> VarSet) -> ([Alt] -> [Var Any]) -> [Alt] -> VarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Alt -> [Var Any]) -> [Alt] -> [Var Any]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Pat -> [Var Any]
forall a. Pat -> [Var a]
patVars (Pat -> [Var Any]) -> (Alt -> Pat) -> Alt -> [Var Any]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Pat
forall a b. (a, b) -> a
fst)) [Alt]
alts)
    (Kind
ty1,[LetBinding]
vs,[Either Term Kind]
args1) <- InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> RewriteMonad
     NormalizeState (Kind, [LetBinding], [Either Term Kind])
forall extra (m :: Type -> Type).
(MonadState (RewriteState extra) m, MonadReader RewriteEnv m,
 MonadUnique m, MonadFail m) =>
InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> m (Kind, [LetBinding], [Either Term Kind])
goCaseArg InScopeSet
isA1 Kind
ty0 [] [Either Term Kind]
args0
    case [LetBinding]
vs of
      [] -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term) -> ([Alt] -> Term) -> [Alt] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Kind -> [Alt] -> Term
Case Term
scrut Kind
ty1 ([Alt] -> Term)
-> RewriteMonad NormalizeState [Alt]
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt -> RewriteMonad NormalizeState Alt)
-> [Alt] -> RewriteMonad NormalizeState [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InScopeSet
-> [Either Term Kind] -> Alt -> RewriteMonad NormalizeState Alt
goAlt InScopeSet
is0 [Either Term Kind]
args1) [Alt]
alts
      [LetBinding]
_  -> do
        let vbs :: [Var Term]
vbs   = (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]
vs
            is1 :: InScopeSet
is1   = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Var Term]
vbs
            alts1 :: [Alt]
alts1 = (Alt -> Alt) -> [Alt] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => InScopeSet -> Alt -> Alt
InScopeSet -> Alt -> Alt
deShadowAlt InScopeSet
is1) [Alt]
alts
        [LetBinding] -> Term -> Term
Letrec [LetBinding]
vs (Term -> Term) -> ([Alt] -> Term) -> [Alt] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term) -> ([Alt] -> Term) -> [Alt] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Kind -> [Alt] -> Term
Case Term
scrut Kind
ty1 ([Alt] -> Term)
-> RewriteMonad NormalizeState [Alt]
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt -> RewriteMonad NormalizeState Alt)
-> [Alt] -> RewriteMonad NormalizeState [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InScopeSet
-> [Either Term Kind] -> Alt -> RewriteMonad NormalizeState Alt
goAlt InScopeSet
is1 [Either Term Kind]
args1) [Alt]
alts1

  go InScopeSet
is0 (Tick TickInfo
sp Term
e) [Either Term Kind]
args [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is0 Term
e [Either Term Kind]
args (TickInfo
spTickInfo -> [TickInfo] -> [TickInfo]
forall a. a -> [a] -> [a]
:[TickInfo]
ticks)

  go InScopeSet
_ Term
fun [Either Term Kind]
args [TickInfo]
ticks = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks Term
fun [TickInfo]
ticks) [Either Term Kind]
args)

  goAlt :: InScopeSet
-> [Either Term Kind] -> Alt -> RewriteMonad NormalizeState Alt
goAlt InScopeSet
is0 [Either Term Kind]
args0 (Pat
p,Term
e) = do
    let ([TyVar]
tvs,[Var Term]
ids) = Pat -> ([TyVar], [Var Term])
patIds Pat
p
        is1 :: InScopeSet
is1       = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList (InScopeSet -> [TyVar] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [TyVar]
tvs) [Var Term]
ids
    (Pat
p,) (Term -> Alt)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Alt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Term
-> [Either Term Kind]
-> [TickInfo]
-> RewriteMonad NormalizeState Term
go InScopeSet
is1 Term
e [Either Term Kind]
args0 []

  goCaseArg :: InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> m (Kind, [LetBinding], [Either Term Kind])
goCaseArg InScopeSet
isA Kind
ty0 [LetBinding]
ls0 (Right Kind
t:[Either Term Kind]
args0) = 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
Lens' RewriteEnv TyConMap
tcCache
    let ty1 :: Kind
ty1 = HasCallStack => TyConMap -> Kind -> Kind -> Kind
TyConMap -> Kind -> Kind -> Kind
piResultTy TyConMap
tcm Kind
ty0 Kind
t
    (Kind
ty2,[LetBinding]
ls1,[Either Term Kind]
args1) <- InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> m (Kind, [LetBinding], [Either Term Kind])
goCaseArg InScopeSet
isA Kind
ty1 [LetBinding]
ls0 [Either Term Kind]
args0
    (Kind, [LetBinding], [Either Term Kind])
-> m (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Kind
ty2,[LetBinding]
ls1,Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
tEither Term Kind -> [Either Term Kind] -> [Either Term Kind]
forall a. a -> [a] -> [a]
:[Either Term Kind]
args1)

  goCaseArg InScopeSet
isA0 Kind
ty0 [LetBinding]
ls0 (Left Term
arg:[Either Term Kind]
args0) = 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
Lens' RewriteEnv TyConMap
tcCache
    VarEnv (Binding Term)
bndrs <- Getting
  (VarEnv (Binding Term))
  (RewriteState extra)
  (VarEnv (Binding Term))
-> m (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 extra)
  (VarEnv (Binding Term))
forall extra. Lens' (RewriteState extra) (VarEnv (Binding Term))
bindings
    let argTy :: Kind
argTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
arg
        ty1 :: Kind
ty1   = TyConMap -> Kind -> Kind -> Kind
applyFunTy TyConMap
tcm Kind
ty0 Kind
argTy
    [m Bool] -> m Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [Bool -> m Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term -> Bool
isVar Term
arg), Lens' (RewriteState extra) (VarEnv Bool)
-> VarEnv (Binding Term) -> Term -> m Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState extra) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
arg] m Bool
-> (Bool -> m (Kind, [LetBinding], [Either Term Kind]))
-> m (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        (Kind
ty2,[LetBinding]
ls1,[Either Term Kind]
args1) <- InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> m (Kind, [LetBinding], [Either Term Kind])
goCaseArg InScopeSet
isA0 Kind
ty1 [LetBinding]
ls0 [Either Term Kind]
args0
        (Kind, [LetBinding], [Either Term Kind])
-> m (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Kind
ty2,[LetBinding]
ls1,Term -> Either Term Kind
forall a b. a -> Either a b
Left Term
argEither Term Kind -> [Either Term Kind] -> [Either Term Kind]
forall a. a -> [a] -> [a]
:[Either Term Kind]
args1)
      Bool
False -> do
        Var Term
boundArg <- InScopeSet -> TyConMap -> Name Term -> Term -> m (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
isA0 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx Text
"app_arg") Term
arg
        let isA1 :: InScopeSet
isA1 = InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isA0 Var Term
boundArg
        (Kind
ty2,[LetBinding]
ls1,[Either Term Kind]
args1) <- InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> m (Kind, [LetBinding], [Either Term Kind])
goCaseArg InScopeSet
isA1 Kind
ty1 [LetBinding]
ls0 [Either Term Kind]
args0
        (Kind, [LetBinding], [Either Term Kind])
-> m (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Kind
ty2,(Var Term
boundArg,Term
arg)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
ls1,Term -> Either Term Kind
forall a b. a -> Either a b
Left (Var Term -> Term
Var Var Term
boundArg)Either Term Kind -> [Either Term Kind] -> [Either Term Kind]
forall a. a -> [a] -> [a]
:[Either Term Kind]
args1)

  goCaseArg InScopeSet
_ Kind
ty [LetBinding]
ls [] = (Kind, [LetBinding], [Either Term Kind])
-> m (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Kind
ty,[LetBinding]
ls,[])
{-# SCC appPropFast #-}

-- | Flatten ridiculous case-statements generated by GHC
--
-- For case-statements in haskell of the form:
--
-- @
-- f :: Unsigned 4 -> Unsigned 4
-- f x = case x of
--   0 -> 3
--   1 -> 2
--   2 -> 1
--   3 -> 0
-- @
--
-- GHC generates Core that looks like:
--
-- @
-- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of
--                             False -> case x == fromInteger 2 of
--                               False -> case x == fromInteger 1 of
--                                 False -> case x == fromInteger 0 of
--                                   False -> error "incomplete case"
--                                   True  -> fromInteger 3
--                                 True -> fromInteger 2
--                               True -> fromInteger 1
--                             True -> fromInteger 0
-- @
--
-- Which would result in a priority decoder circuit where a normal decoder
-- circuit was desired.
--
-- This transformation transforms the above Core to the saner:
--
-- @
-- f = \(x :: Unsigned 4) -> case x of
--        _ -> error "incomplete case"
--        0 -> fromInteger 3
--        1 -> fromInteger 2
--        2 -> fromInteger 1
--        3 -> fromInteger 0
-- @
caseFlat :: HasCallStack => NormRewrite
caseFlat :: NormRewrite
caseFlat TransformContext
_ e :: Term
e@(Case (Term -> Maybe (Term, Term)
collectEqArgs -> Just (Term
scrut',Term
_)) Kind
ty [Alt]
_)
  = do
       case Term -> Term -> Maybe [Alt]
collectFlat Term
scrut' Term
e of
         Just [Alt]
alts' -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> Kind -> [Alt] -> Term
Case Term
scrut' Kind
ty ([Alt] -> Alt
forall a. [a] -> a
last [Alt]
alts' Alt -> [Alt] -> [Alt]
forall a. a -> [a] -> [a]
: [Alt] -> [Alt]
forall a. [a] -> [a]
init [Alt]
alts'))
         Maybe [Alt]
Nothing    -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

collectFlat :: Term -> Term -> Maybe [(Pat,Term)]
collectFlat :: Term -> Term -> Maybe [Alt]
collectFlat Term
scrut (Case (Term -> Maybe (Term, Term)
collectEqArgs -> Just (Term
scrut', Term
val)) Kind
_ty [Alt
lAlt,Alt
rAlt])
  | Term
scrut' Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
scrut
  = case Term -> (Term, [Either Term Kind])
collectArgs Term
val of
      (Prim PrimInfo
p,[Either Term Kind]
args') | Text -> Bool
isFromInt (PrimInfo -> Text
primName PrimInfo
p) ->
        Either Term Kind -> Maybe [Alt]
forall b. Either Term b -> Maybe [Alt]
go ([Either Term Kind] -> Either Term Kind
forall a. [a] -> a
last [Either Term Kind]
args')
      (Data DataCon
dc,[Either Term Kind]
args')    | Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Types.I#" ->
        Either Term Kind -> Maybe [Alt]
forall b. Either Term b -> Maybe [Alt]
go ([Either Term Kind] -> Either Term Kind
forall a. [a] -> a
last [Either Term Kind]
args')
      (Term, [Either Term Kind])
_ -> Maybe [Alt]
forall a. Maybe a
Nothing
  where
    go :: Either Term b -> Maybe [Alt]
go (Left (Literal Literal
i)) = case (Alt
lAlt,Alt
rAlt) of
              ((Pat
pl,Term
el),(Pat
pr,Term
er))
                | Pat -> Bool
isFalseDcPat Pat
pl Bool -> Bool -> Bool
|| Pat -> Bool
isTrueDcPat Pat
pr ->
                   case Term -> Term -> Maybe [Alt]
collectFlat Term
scrut Term
el of
                     Just [Alt]
alts' -> [Alt] -> Maybe [Alt]
forall a. a -> Maybe a
Just ((Literal -> Pat
LitPat Literal
i, Term
er) Alt -> [Alt] -> [Alt]
forall a. a -> [a] -> [a]
: [Alt]
alts')
                     Maybe [Alt]
Nothing    -> [Alt] -> Maybe [Alt]
forall a. a -> Maybe a
Just [(Literal -> Pat
LitPat Literal
i, Term
er)
                                        ,(Pat
DefaultPat, Term
el)
                                        ]
                | Bool
otherwise ->
                   case Term -> Term -> Maybe [Alt]
collectFlat Term
scrut Term
er of
                     Just [Alt]
alts' -> [Alt] -> Maybe [Alt]
forall a. a -> Maybe a
Just ((Literal -> Pat
LitPat Literal
i, Term
el) Alt -> [Alt] -> [Alt]
forall a. a -> [a] -> [a]
: [Alt]
alts')
                     Maybe [Alt]
Nothing    -> [Alt] -> Maybe [Alt]
forall a. a -> Maybe a
Just [(Literal -> Pat
LitPat Literal
i, Term
el)
                                        ,(Pat
DefaultPat, Term
er)
                                        ]
    go Either Term b
_ = Maybe [Alt]
forall a. Maybe a
Nothing

    isFalseDcPat :: Pat -> Bool
isFalseDcPat (DataPat DataCon
p [TyVar]
_ [Var Term]
_)
      = ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Types.False") (Text -> Bool) -> (DataCon -> Text) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name DataCon -> Text
forall a. Name a -> Text
nameOcc (Name DataCon -> Text)
-> (DataCon -> Name DataCon) -> DataCon -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name DataCon
dcName) DataCon
p
    isFalseDcPat Pat
_ = Bool
False

    isTrueDcPat :: Pat -> Bool
isTrueDcPat (DataPat DataCon
p [TyVar]
_ [Var Term]
_)
      = ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Types.True") (Text -> Bool) -> (DataCon -> Text) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name DataCon -> Text
forall a. Name a -> Text
nameOcc (Name DataCon -> Text)
-> (DataCon -> Name DataCon) -> DataCon -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name DataCon
dcName) DataCon
p
    isTrueDcPat Pat
_ = Bool
False

collectFlat Term
_ Term
_ = Maybe [Alt]
forall a. Maybe a
Nothing
{-# SCC collectFlat #-}

collectEqArgs :: Term -> Maybe (Term,Term)
collectEqArgs :: Term -> Maybe (Term, Term)
collectEqArgs (Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Prim PrimInfo
p, [Either Term Kind]
args, [TickInfo]
ticks))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.BitVector.eq#"
    = let [Either Term Kind
_,Either Term Kind
_,Left Term
scrut,Left Term
val] = [Either Term Kind]
args
      in (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term -> [TickInfo] -> Term
mkTicks Term
scrut [TickInfo]
ticks,Term
val)
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Index.eq#"  Bool -> Bool -> Bool
||
    Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Signed.eq#" Bool -> Bool -> Bool
||
    Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.Unsigned.eq#"
    = let [Either Term Kind
_,Left Term
scrut,Left Term
val] = [Either Term Kind]
args
      in (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term -> [TickInfo] -> Term
mkTicks Term
scrut [TickInfo]
ticks,Term
val)
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Transformations.eqInt"
    = let [Left Term
scrut,Left Term
val] = [Either Term Kind]
args
      in  (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term -> [TickInfo] -> Term
mkTicks Term
scrut [TickInfo]
ticks,Term
val)
 where
  nm :: Text
nm = PrimInfo -> Text
primName PrimInfo
p

collectEqArgs Term
_ = Maybe (Term, Term)
forall a. Maybe a
Nothing

type NormRewriteW = Transform (StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState))

-- | See Note [ANF InScopeSet]
tellBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m ()
tellBinders :: [LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
bs = (([LetBinding], InScopeSet) -> ([LetBinding], InScopeSet))
-> StateT ([LetBinding], InScopeSet) m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (([LetBinding]
bs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++) ([LetBinding] -> [LetBinding])
-> (InScopeSet -> InScopeSet)
-> ([LetBinding], InScopeSet)
-> ([LetBinding], InScopeSet)
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ((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]
bs)))

-- | See Note [ANF InScopeSet]; only extends the inscopeset
notifyBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m ()
notifyBinders :: [LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
notifyBinders [LetBinding]
bs = (([LetBinding], InScopeSet) -> ([LetBinding], InScopeSet))
-> StateT ([LetBinding], InScopeSet) m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify ((InScopeSet -> InScopeSet)
-> ([LetBinding], InScopeSet) -> ([LetBinding], InScopeSet)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ((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]
bs)))

-- | Is the given type IO-like
isSimIOTy
  :: TyConMap
  -> Type
  -- ^ Type to check for IO-likeness
  -> Bool
isSimIOTy :: TyConMap -> Kind -> Bool
isSimIOTy TyConMap
tcm Kind
ty = case Kind -> TypeView
tyView (TyConMap -> Kind -> Kind
coreView TyConMap
tcm Kind
ty) of
  TyConApp TyConName
tcNm [Kind]
args
    | TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.SimIO"
    -> Bool
True
    | TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Prim.(#,#)"
    , [Kind
_,Kind
_,Kind
st,Kind
_] <- [Kind]
args
    -> TyConMap -> Kind -> Bool
isStateTokenTy TyConMap
tcm Kind
st
  FunTy Kind
_ Kind
res -> TyConMap -> Kind -> Bool
isSimIOTy TyConMap
tcm Kind
res
  TypeView
_ -> Bool
False

-- | Is the given type the state token
isStateTokenTy
  :: TyConMap
  -> Type
  -- ^ Type to check for state tokenness
  -> Bool
isStateTokenTy :: TyConMap -> Kind -> Bool
isStateTokenTy TyConMap
tcm Kind
ty = case Kind -> TypeView
tyView (TyConMap -> Kind -> Kind
coreView TyConMap
tcm Kind
ty) of
  TyConApp TyConName
tcNm [Kind]
_ -> TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"GHC.Prim.State#"
  TypeView
_ -> Bool
False

-- | Turn an expression into a modified ANF-form. As opposed to standard ANF,
-- constants do not become let-bound.
makeANF :: HasCallStack => NormRewrite
makeANF :: NormRewrite
makeANF (TransformContext InScopeSet
is0 Context
ctx) (Lam Var Term
bndr Term
e) = do
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
makeANF (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Var Term
bndr)
                                  (Var Term -> CoreContext
LamBody Var Term
bndrCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
                Term
e
  Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Var Term -> Term -> Term
Lam Var Term
bndr Term
e')

makeANF TransformContext
_ e :: Term
e@(TyLam {}) = Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

makeANF ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
_) Term
e0
  = do
    -- We need to freshen all binders in `e` because we're shuffling them around
    -- into a single let-binder, because even when binders don't shadow, they
    -- don't have to be unique within an expression. And so lifting them all
    -- to a single let-binder will cause issues when they're not unique.
    --
    -- We cannot make freshening part of collectANF, because when we generate
    -- new binders, we need to make sure those names do not conflict with _any_
    -- of the existing binders in the expression.
    --
    -- See also Note [ANF InScopeSet]
    let (InScopeSet
is2,Term
e1) = InScopeSet -> Term -> (InScopeSet, Term)
freshenTm InScopeSet
is0 Term
e0
    ((Term
e2,([LetBinding]
bndrs,InScopeSet
_)),Any -> Bool
Monoid.getAny -> Bool
hasChanged) <-
      RewriteMonad NormalizeState (Term, ([LetBinding], InScopeSet))
-> RewriteMonad
     NormalizeState ((Term, ([LetBinding], InScopeSet)), Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen (StateT
  ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
-> ([LetBinding], InScopeSet)
-> RewriteMonad NormalizeState (Term, ([LetBinding], InScopeSet))
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT (Transform
  (StateT ([LetBinding], InScopeSet) (RewriteMonad NormalizeState))
-> Transform
     (StateT ([LetBinding], InScopeSet) (RewriteMonad NormalizeState))
forall (m :: Type -> Type). Monad m => Transform m -> Transform m
bottomupR HasCallStack =>
Transform
  (StateT ([LetBinding], InScopeSet) (RewriteMonad NormalizeState))
Transform
  (StateT ([LetBinding], InScopeSet) (RewriteMonad NormalizeState))
collectANF TransformContext
ctx Term
e1) ([],InScopeSet
is2))
    case [LetBinding]
bndrs of
      [] -> if Bool
hasChanged then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e2 else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e0
      [LetBinding]
_  -> do
        let (Term
e3,[TickInfo]
ticks) = Term -> (Term, [TickInfo])
collectTicks Term
e2
            ([TickInfo]
srcTicks,[TickInfo]
nmTicks) = [TickInfo] -> ([TickInfo], [TickInfo])
partitionTicks [TickInfo]
ticks
        -- Ensure that `AppendName` ticks still scope over the entire expression
        Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bndrs (Term -> [TickInfo] -> Term
mkTicks Term
e3 [TickInfo]
srcTicks)) [TickInfo]
nmTicks)
{-# SCC makeANF #-}

-- | Note [ANF InScopeSet]
--
-- The InScopeSet contains:
--
--    1. All the free variables of the expression we are traversing
--
--    2. All the bound variables of the expression we are traversing
--
--    3. The newly created let-bindings as we recurse back up the traversal
--
-- All of these are needed to created let-bindings that
--
--    * Do not shadow
--    * Are not shadowed
--    * Nor conflict with each other (i.e. have the same unique)
--
-- Initially we start with the local InScopeSet and add the global variables:
--
-- @
-- is1 <- unionInScope is0 <$> Lens.use globalInScope
-- @
--
-- Which will gives us the (superset of) free variables of the expression. Then
-- we call  'freshenTm'
--
-- @
-- let (is2,e1) = freshenTm is1 e0
-- @
--
-- Which extends the InScopeSet with all the bound variables in 'e1', the
-- version of 'e0' where all binders are unique (not just deshadowed).
--
-- So we start out with an InScopeSet that satisfies points 1 and 2, now every
-- time we create a new binder we must add it to the InScopeSet to satisfy
-- point 3.
--
-- Note [ANF no let-bind]
--
-- | Do not let-bind:
--
-- 1. Arguments with an untranslatable type: untranslatable expressions
--    should be propagated down as far as possible
--
-- 2. Local variables or constants: they don't add any work, so no reason
--    to let-bind to enable sharing
--
-- 3. IO actions, the translation of IO actions to sequential HDL constructs
--    depends on IO actions to be propagated down as far as possible.
collectANF :: HasCallStack => NormRewriteW
collectANF :: Transform
  (StateT ([LetBinding], InScopeSet) (RewriteMonad NormalizeState))
collectANF TransformContext
ctx e :: Term
e@(App Term
appf Term
arg)
  | (Term
conVarPrim, [Either Term Kind]
_) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e
  , Term -> Bool
isCon Term
conVarPrim Bool -> Bool -> Bool
|| Term -> Bool
isPrim Term
conVarPrim Bool -> Bool -> Bool
|| Term -> Bool
isVar Term
conVarPrim
  = do
    TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
    Bool
untranslatable <- RewriteMonad NormalizeState Bool
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Bool
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
False Term
arg)
    let localVar :: Bool
localVar   = Term -> Bool
isLocalVar Term
arg
        constantNoCR :: Bool
constantNoCR = TyConMap -> Term -> Bool
isConstantNotClockReset TyConMap
tcm Term
arg
    -- See Note [ANF no let-bind]
    case (Bool
untranslatable,Bool
localVar Bool -> Bool -> Bool
|| Bool
constantNoCR, Term -> Bool
isSimBind Term
conVarPrim,Term
arg) of
      (Bool
False,Bool
False,Bool
False,Term
_) -> do
        -- See Note [ANF InScopeSet]
        InScopeSet
is1   <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
        Var Term
argId <- RewriteMonad NormalizeState (Var Term)
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) (Var Term)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InScopeSet
-> TyConMap
-> Name Term
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx Text
"app_arg") Term
arg)
        -- See Note [ANF InScopeSet]
        [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [(Var Term
argId,Term
arg)]
        Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Term -> Term
App Term
appf (Var Term -> Term
Var Var Term
argId))
      (Bool
True,Bool
False,Bool
_,Letrec [LetBinding]
binds Term
body) -> do
        [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
binds
        Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Term -> Term
App Term
appf Term
body)
      (Bool, Bool, Bool, Term)
_ -> Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
 where
  isSimBind :: Term -> Bool
isSimBind (Prim PrimInfo
p) = PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Explicit.SimIO.bindSimIO#"
  isSimBind Term
_ = Bool
False

collectANF TransformContext
_ (Letrec [LetBinding]
binds Term
body) = do
  TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
  let isSimIO :: Bool
isSimIO = TyConMap -> Kind -> Bool
isSimIOTy TyConMap
tcm (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
body)
  Bool
untranslatable <- RewriteMonad NormalizeState Bool
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Bool
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
False Term
body)
  let localVar :: Bool
localVar = Term -> Bool
isLocalVar Term
body
  -- See Note [ANF no let-bind]
  if Bool
localVar Bool -> Bool -> Bool
|| Bool
untranslatable Bool -> Bool -> Bool
|| Bool
isSimIO
    then do
      [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
binds
      Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
body
    else do
      -- See Note [ANF InScopeSet]
      InScopeSet
is1 <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
      Var Term
argId <- RewriteMonad NormalizeState (Var Term)
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) (Var Term)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InScopeSet
-> TyConMap
-> Name Any
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName Text
"result" Int
0) Term
body)
      -- See Note [ANF InScopeSet]
      [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [(Var Term
argId,Term
body)]
      [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
binds
      Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Var Term -> Term
Var Var Term
argId)

-- TODO: The code below special-cases ANF for the ':-' constructor for the
-- 'Signal' type. The 'Signal' type is essentially treated as a "transparent"
-- type by the Clash compiler, so observing its constructor leads to all kinds
-- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will
-- try to project the LHS and RHS of the ':-' constructor, however,
-- 'mkSelectorCase' uses 'coreView1' to find the "real" data-constructor.
-- 'coreView1' however looks through the 'Signal' type, and hence 'mkSelector'
-- finds the data constructors for the element type of Signal. This resulted in
-- error #24 (https://github.com/christiaanb/clash2/issues/24), where we
-- try to get the first field out of the 'Vec's 'Nil' constructor.
--
-- Ultimately we should stop treating Signal as a "transparent" type and deal
-- handling of the Signal type, and the involved co-recursive functions,
-- properly. At the moment, Clash cannot deal with this recursive type and the
-- recursive functions involved, hence the need for special-casing code. After
-- everything is done properly, we should remove the two lines below.
collectANF TransformContext
_ e :: Term
e@(Case Term
_ Kind
_ [(DataPat DataCon
dc [TyVar]
_ [Var Term]
_,Term
_)])
  | Name DataCon -> Text
forall a. Name a -> Text
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Signal.Internal.:-" = Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

collectANF TransformContext
ctx (Case Term
subj Kind
ty [Alt]
alts) = do
    let localVar :: Bool
localVar = Term -> Bool
isLocalVar Term
subj
    let isConstantSubj :: Bool
isConstantSubj = Term -> Bool
isConstant Term
subj

    (Term
subj',[LetBinding]
subjBinders) <- if Bool
localVar Bool -> Bool -> Bool
|| Bool
isConstantSubj
      then (Term, [LetBinding])
-> StateT
     ([LetBinding], InScopeSet)
     (RewriteMonad NormalizeState)
     (Term, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term
subj,[])
      else do
        TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
        -- See Note [ANF InScopeSet]
        InScopeSet
is1 <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
        Var Term
argId <- RewriteMonad NormalizeState (Var Term)
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) (Var Term)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InScopeSet
-> TyConMap
-> Name Term
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx Text
"case_scrut") Term
subj)
        -- See Note [ANF InScopeSet]
        [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
notifyBinders [(Var Term
argId,Term
subj)]
        (Term, [LetBinding])
-> StateT
     ([LetBinding], InScopeSet)
     (RewriteMonad NormalizeState)
     (Term, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Var Term -> Term
Var Var Term
argId,[(Var Term
argId,Term
subj)])

    TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
    let isSimIOAlt :: Bool
isSimIOAlt = TyConMap -> Kind -> Bool
isSimIOTy TyConMap
tcm Kind
ty

    [Alt]
alts' <- (Alt
 -> StateT
      ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt)
-> [Alt]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) [Alt]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool
-> Term
-> Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
doAlt Bool
isSimIOAlt Term
subj') [Alt]
alts
    [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
subjBinders

    case [Alt]
alts' of
      [(DataPat DataCon
_ [] [Var Term]
xs,Term
altExpr)]
        | [Var Term]
xs [Var Term] -> Term -> Bool
`localIdsDoNotOccurIn` Term
altExpr Bool -> Bool -> Bool
|| Bool
isSimIOAlt
        -> Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
altExpr
      [Alt]
_ -> Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> Kind -> [Alt] -> Term
Case Term
subj' Kind
ty [Alt]
alts')
  where
    doAlt
      :: Bool -> Term -> (Pat,Term)
      -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState)
                (Pat,Term)
    doAlt :: Bool
-> Term
-> Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
doAlt Bool
isSimIOAlt Term
subj' alt :: Alt
alt@(DataPat DataCon
dc [TyVar]
exts [Var Term]
xs,Term
altExpr) | Bool -> Bool
not ([TyVar] -> [Var Term] -> Bool
forall a. [TyVar] -> [Var a] -> Bool
bindsExistentials [TyVar]
exts [Var Term]
xs) = do
      let lv :: Bool
lv = Term -> Bool
isLocalVar Term
altExpr
      [LetBinding]
patSels <- (Var Term
 -> Int
 -> StateT
      ([LetBinding], InScopeSet)
      (RewriteMonad NormalizeState)
      LetBinding)
-> [Var Term]
-> [Int]
-> StateT
     ([LetBinding], InScopeSet)
     (RewriteMonad NormalizeState)
     [LetBinding]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
Monad.zipWithM (Term
-> DataCon
-> Var Term
-> Int
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) LetBinding
doPatBndr Term
subj' DataCon
dc) [Var Term]
xs [Int
0..]
      let altExprIsConstant :: Bool
altExprIsConstant = Term -> Bool
isConstant Term
altExpr
      let usesXs :: Term -> Bool
usesXs (Var Var Term
n) = (Var Term -> Bool) -> [Var Term] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Var Term -> Var Term -> Bool
forall a. Eq a => a -> a -> Bool
== Var Term
n) [Var Term]
xs
          usesXs Term
_       = Bool
False
      -- See [ANF no let-bind]
      if [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or [Bool
isSimIOAlt, Bool
lv Bool -> Bool -> Bool
&& (Bool -> Bool
not (Term -> Bool
usesXs Term
altExpr) Bool -> Bool -> Bool
|| [Alt] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Alt]
alts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1), Bool
altExprIsConstant]
        then do
          -- See Note [ANF InScopeSet]
          [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [LetBinding]
patSels
          Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt
        else do
          TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
          -- See Note [ANF InScopeSet]
          InScopeSet
is1 <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
          Var Term
altId <- RewriteMonad NormalizeState (Var Term)
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) (Var Term)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InScopeSet
-> TyConMap
-> Name Term
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx Text
"case_alt") Term
altExpr)
          -- See Note [ANF InScopeSet]
          [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders ([LetBinding]
patSels [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Var Term
altId,Term
altExpr)])
          Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataCon -> [TyVar] -> [Var Term] -> Pat
DataPat DataCon
dc [TyVar]
exts [Var Term]
xs,Var Term -> Term
Var Var Term
altId)
    doAlt Bool
_ Term
_ alt :: Alt
alt@(DataPat {}, Term
_) = Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt
    doAlt Bool
isSimIOAlt Term
_ alt :: Alt
alt@(Pat
pat,Term
altExpr) = do
      let lv :: Bool
lv = Term -> Bool
isLocalVar Term
altExpr
      let altExprIsConstant :: Bool
altExprIsConstant = Term -> Bool
isConstant Term
altExpr
      -- See [ANF no let-bind]
      if Bool
isSimIOAlt Bool -> Bool -> Bool
|| Bool
lv Bool -> Bool -> Bool
|| Bool
altExprIsConstant
        then Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt
        else do
          TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
          -- See Note [ANF InScopeSet]
          InScopeSet
is1 <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
          Var Term
altId <- RewriteMonad NormalizeState (Var Term)
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) (Var Term)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InScopeSet
-> TyConMap
-> Name Term
-> Term
-> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m (Var Term)
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx Text
"case_alt") Term
altExpr)
          [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [(Var Term
altId,Term
altExpr)]
          Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pat
pat,Var Term -> Term
Var Var Term
altId)

    doPatBndr
      :: Term -> DataCon -> Id -> Int
      -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState)
                LetBinding
    doPatBndr :: Term
-> DataCon
-> Var Term
-> Int
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) LetBinding
doPatBndr Term
subj' DataCon
dc Var Term
pId Int
i
      = do
        TyConMap
tcm <- Getting TyConMap RewriteEnv TyConMap
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) TyConMap
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting TyConMap RewriteEnv TyConMap
Lens' RewriteEnv TyConMap
tcCache
        -- See Note [ANF InScopeSet]
        InScopeSet
is1 <- Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) InScopeSet
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting InScopeSet ([LetBinding], InScopeSet) InScopeSet
forall s t a b. Field2 s t a b => Lens s t a b
_2
        Term
patExpr <- RewriteMonad NormalizeState Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String
-> InScopeSet
-> TyConMap
-> Term
-> Int
-> Int
-> RewriteMonad NormalizeState Term
forall (m :: Type -> Type).
(HasCallStack, MonadUnique m) =>
String -> InScopeSet -> TyConMap -> Term -> Int -> Int -> m Term
mkSelectorCase ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"doPatBndr") InScopeSet
is1 TyConMap
tcm Term
subj' (DataCon -> Int
dcTag DataCon
dc) Int
i)
        -- No need to 'tellBinders' here because 'pId' is already in the ANF
        -- InScopeSet.
        --
        -- See also Note [ANF InScopeSet]
        LetBinding
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) LetBinding
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Var Term
pId,Term
patExpr)

collectANF TransformContext
_ Term
e = Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC collectANF #-}

-- | Eta-expand top-level lambda's (DON'T use in a traversal!)
etaExpansionTL :: HasCallStack => NormRewrite
etaExpansionTL :: NormRewrite
etaExpansionTL (TransformContext InScopeSet
is0 Context
ctx) (Lam Var Term
bndr Term
e) = do
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL
          (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Var Term
bndr) (Var Term -> CoreContext
LamBody Var Term
bndrCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
          Term
e
  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
$ Var Term -> Term -> Term
Lam Var Term
bndr Term
e'

etaExpansionTL (TransformContext InScopeSet
is0 Context
ctx) (Letrec [LetBinding]
xes Term
e) = do
  let bndrs :: [Var Term]
bndrs = (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]
xes
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL
          (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Var Term]
bndrs)
                            ([Var Term] -> CoreContext
LetBody [Var Term]
bndrsCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
          Term
e
  case Term -> ([Var Term], Term)
stripLambda Term
e' of
    (bs :: [Var Term]
bs@(Var Term
_:[Var Term]
_),Term
e2) -> do
      let e3 :: Term
e3 = [LetBinding] -> Term -> Term
Letrec [LetBinding]
xes Term
e2
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [Var Term] -> Term
mkLams Term
e3 [Var Term]
bs)
    ([Var Term], Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
Letrec [LetBinding]
xes Term
e')
  where
    stripLambda :: Term -> ([Id],Term)
    stripLambda :: Term -> ([Var Term], Term)
stripLambda (Lam Var Term
bndr Term
e0) =
      let ([Var Term]
bndrs,Term
e1) = Term -> ([Var Term], Term)
stripLambda Term
e0
      in  (Var Term
bndrVar Term -> [Var Term] -> [Var Term]
forall a. a -> [a] -> [a]
:[Var Term]
bndrs,Term
e1)
    stripLambda Term
e' = ([],Term
e')

etaExpansionTL (TransformContext InScopeSet
is0 Context
ctx) Term
e
  = 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
Lens' RewriteEnv TyConMap
tcCache
    if TyConMap -> Term -> Bool
isFun TyConMap
tcm Term
e
      then do
        let argTy :: Kind
argTy = ( (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst
                    ((Kind, Kind) -> Kind) -> (Term -> (Kind, Kind)) -> Term -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind, Kind) -> Maybe (Kind, Kind) -> (Kind, Kind)
forall a. a -> Maybe a -> a
Maybe.fromMaybe (String -> (Kind, Kind)
forall a. HasCallStack => String -> a
error (String -> (Kind, Kind)) -> String -> (Kind, Kind)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"etaExpansion splitFunTy")
                    (Maybe (Kind, Kind) -> (Kind, Kind))
-> (Term -> Maybe (Kind, Kind)) -> Term -> (Kind, Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Kind -> Maybe (Kind, Kind)
splitFunTy TyConMap
tcm
                    (Kind -> Maybe (Kind, Kind))
-> (Term -> Kind) -> Term -> Maybe (Kind, Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Term -> Kind
termType TyConMap
tcm
                    ) Term
e
        Var Term
newId <- InScopeSet
-> Text -> Kind -> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m (Var Term)
mkInternalVar InScopeSet
is0 Text
"arg" Kind
argTy
        Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Var Term
newId)
                                               (Var Term -> CoreContext
LamBody Var Term
newIdCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
                             (Term -> Term -> Term
App Term
e (Var Term -> Term
Var Var Term
newId))
        Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Var Term -> Term -> Term
Lam Var Term
newId Term
e')
      else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
{-# SCC etaExpansionTL #-}

-- | Eta-expand functions with a Synthesize annotation, needed to allow such
-- functions to appear as arguments to higher-order primitives.
etaExpandSyn :: HasCallStack => NormRewrite
etaExpandSyn :: NormRewrite
etaExpandSyn (TransformContext InScopeSet
is0 Context
ctx) e :: Term
e@(Term -> (Term, [Either Term Kind])
collectArgs -> (Var Var Term
f, [Either Term Kind]
_)) = do
  VarSet
topEnts <- Getting VarSet RewriteEnv VarSet
-> RewriteMonad NormalizeState VarSet
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting VarSet RewriteEnv VarSet
Lens' RewriteEnv VarSet
topEntities
  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
Lens' RewriteEnv TyConMap
tcCache
  let isTopEnt :: Bool
isTopEnt = Var Term
f Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
topEnts
      isAppFunCtx :: Context -> Bool
isAppFunCtx =
        \case
          CoreContext
AppFun:Context
_ -> Bool
True
          TickC TickInfo
_:Context
c -> Context -> Bool
isAppFunCtx Context
c
          Context
_ -> Bool
False
      argTyM :: Maybe Kind
argTyM = ((Kind, Kind) -> Kind) -> Maybe (Kind, Kind) -> Maybe Kind
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst (TyConMap -> Kind -> Maybe (Kind, Kind)
splitFunTy TyConMap
tcm (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e))
  case Maybe Kind
argTyM of
    Just Kind
argTy | Bool
isTopEnt Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
isAppFunCtx Context
ctx) -> do
      Var Term
newId <- InScopeSet
-> Text -> Kind -> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m (Var Term)
mkInternalVar InScopeSet
is0 Text
"arg" Kind
argTy
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Var Term -> Term -> Term
Lam Var Term
newId (Term -> Term -> Term
App Term
e (Var Term -> Term
Var Var Term
newId)))
    Maybe Kind
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

isClassConstraint :: Type -> Bool
isClassConstraint :: Kind -> Bool
isClassConstraint (Kind -> TypeView
tyView -> TyConApp TyConName
nm0 [Kind]
_) =
  if -- Constraint tuple:
     | Text
"GHC.Classes.(%" Text -> Text -> Bool
`Text.isInfixOf` Text
nm1 -> Bool
True
     -- Constraint class:
     | Text
"C:" Text -> Text -> Bool
`Text.isInfixOf` Text
nm2 -> Bool
True
     | Bool
otherwise -> Bool
False
 where
  nm1 :: Text
nm1 = TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
nm0
  nm2 :: Text
nm2 = (Text, Text) -> Text
forall a b. (a, b) -> b
snd (Text -> Text -> (Text, Text)
Text.breakOnEnd Text
"." Text
nm1)

isClassConstraint Kind
_ = Bool
False


-- | Turn a  normalized recursive function, where the recursive calls only pass
-- along the unchanged original arguments, into let-recursive function. This
-- means that all recursive calls are replaced by the same variable reference as
-- found in the body of the top-level let-expression.
recToLetRec :: HasCallStack => NormRewrite
recToLetRec :: NormRewrite
recToLetRec (TransformContext InScopeSet
is0 []) Term
e = do
  (Var Term
fn,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
  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
Lens' RewriteEnv TyConMap
tcCache
  case TyConMap
-> Term -> Either String ([Var Term], [LetBinding], Var Term)
splitNormalized TyConMap
tcm Term
e of
    Right ([Var Term]
args,[LetBinding]
bndrs,Var Term
res) -> do
      let args' :: [Term]
args'             = (Var Term -> Term) -> [Var Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Var Term -> Term
Var [Var Term]
args
          ([LetBinding]
toInline,[LetBinding]
others) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (TyConMap -> Var Term -> [Term] -> Term -> Bool
eqApp TyConMap
tcm Var Term
fn [Term]
args' (Term -> Bool) -> (LetBinding -> Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Term
forall a b. (a, b) -> b
snd) [LetBinding]
bndrs
          resV :: Term
resV              = Var Term -> Term
Var Var Term
res
      case ([LetBinding]
toInline,[LetBinding]
others) of
        (LetBinding
_:[LetBinding]
_,LetBinding
_:[LetBinding]
_) -> do
          let is1 :: InScopeSet
is1          = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ([Var Term]
args [Var Term] -> [Var Term] -> [Var Term]
forall a. [a] -> [a] -> [a]
++ (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]
bndrs)
          let substsInline :: Subst
substsInline = Subst -> [LetBinding] -> Subst
extendIdSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is1)
                           ([LetBinding] -> Subst) -> [LetBinding] -> Subst
forall a b. (a -> b) -> a -> b
$ (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> Term -> Term
forall a b. a -> b -> a
const Term
resV)) [LetBinding]
toInline
              others' :: [LetBinding]
others'      = (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"recToLetRec" Subst
substsInline))
                                 [LetBinding]
others
          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 -> [Var Term] -> Term
mkLams ([LetBinding] -> Term -> Term
Letrec [LetBinding]
others' Term
resV) [Var Term]
args
        ([LetBinding], [LetBinding])
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    Either String ([Var Term], [LetBinding], Var Term)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
  where
    -- This checks whether things are semantically equal. For example, say we
    -- have:
    --
    --   x :: (a, (b, c))
    --
    -- and
    --
    --   y :: (a, (b, c))
    --
    -- If we can determine that 'y' is constructed solely using the
    -- corresponding fields in 'x', then we can say they are semantically
    -- equal. The algorithm below keeps track of what (sub)field it is
    -- constructing, and checks if the field-expression projects the
    -- corresponding (sub)field from the target variable.
    --
    -- TODO: See [Note: Breaks on constants and predetermined equality]
    eqApp :: TyConMap -> Var Term -> [Term] -> Term -> Bool
eqApp TyConMap
tcm Var Term
v [Term]
args (Term -> (Term, [Either Term Kind])
collectArgs (Term -> (Term, [Either Term Kind]))
-> (Term -> Term) -> Term -> (Term, [Either Term Kind])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
stripTicks -> (Var Var Term
v',[Either Term Kind]
args'))
      | Var Term -> Bool
forall a. Var a -> Bool
isGlobalId Var Term
v'
      , Var Term
v Var Term -> Var Term -> Bool
forall a. Eq a => a -> a -> Bool
== Var Term
v'
      , let args2 :: [Term]
args2 = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args'
      , [Term] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Term]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Term] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Term]
args2
      = [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and ((Term -> Term -> Bool) -> [Term] -> [Term] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TyConMap -> Term -> Term -> Bool
eqArg TyConMap
tcm) [Term]
args [Term]
args2)
    eqApp TyConMap
_ Var Term
_ [Term]
_ Term
_ = Bool
False

    eqArg :: TyConMap -> Term -> Term -> Bool
eqArg TyConMap
_ Term
v1 v2 :: Term
v2@(Term -> Term
stripTicks -> Var {})
      = Term
v1 Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
v2
    eqArg TyConMap
tcm Term
v1 v2 :: Term
v2@(Term -> (Term, [Either Term Kind])
collectArgs (Term -> (Term, [Either Term Kind]))
-> (Term -> Term) -> Term -> (Term, [Either Term Kind])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
stripTicks -> (Data DataCon
_, [Either Term Kind]
args'))
      | let t1 :: Kind
t1 = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
v1)
      , let t2 :: Kind
t2 = TyConMap -> Kind -> Kind
normalizeType TyConMap
tcm (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
v2)
      , Kind
t1 Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
t2
      = if Kind -> Bool
isClassConstraint Kind
t1 then
          -- Class constraints are equal if their types are equal, so we can
          -- take a shortcut here.
          Bool
True
        else
          -- Check whether all arguments to the data constructor are projections
          --
          [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and (([Int] -> Term -> Bool) -> [[Int]] -> [Term] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Term -> [Int] -> Term -> Bool
eqDat Term
v1) ((Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Int]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Int
0..]) ([Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args'))
    eqArg TyConMap
_ Term
_ Term
_
      = Bool
False

    -- Recursively check whether a term /e/ is semantically equal to some variable /v/.
    -- Currently it can only assert equality when /e/ is  syntactically equal
    -- to /v/, or is constructed out of projections of /v/, importantly:
    --
    -- [Note: Breaks on constants and predetermined equality]
    -- This function currently breaks if:
    --
    --   * One or more subfields are constants. Constants might have been
    --     inlined for the construction, instead of being a projection of the
    --     target variable.
    --
    --   * One or more subfields are determined to be equal and one is simply
    --     swapped / replaced by the other. For example, say we have
    --     `x :: (a, a)`. If GHC determines that both elements of the tuple will
    --     always be the same, it might replace the (semantically equal to 'x')
    --     construction of `y` with `(fst x, fst x)`.
    --
    eqDat :: Term -> [Int] -> Term -> Bool
    eqDat :: Term -> [Int] -> Term -> Bool
eqDat Term
v [Int]
fTrace (Term -> (Term, [Either Term Kind])
collectArgs (Term -> (Term, [Either Term Kind]))
-> (Term -> Term) -> Term -> (Term, [Either Term Kind])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
stripTicks -> (Data DataCon
_, [Either Term Kind]
args)) =
      [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
and (([Int] -> Term -> Bool) -> [[Int]] -> [Term] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Term -> [Int] -> Term -> Bool
eqDat Term
v) ((Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
fTrace) [Int
0..]) ([Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args))
    eqDat Term
v1 [Int]
fTrace Term
v2 =
      case [Int] -> Term -> Term -> Maybe [Int]
stripProjection ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
fTrace) Term
v1 Term
v2 of
        Just [] -> Bool
True
        Maybe [Int]
_ -> Bool
False

    stripProjection :: [Int] -> Term -> Term -> Maybe [Int]
    stripProjection :: [Int] -> Term -> Term -> Maybe [Int]
stripProjection [Int]
fTrace0 Term
vTarget0 (Case Term
v Kind
_ [(DataPat DataCon
_ [TyVar]
_ [Var Term]
xs, Term
r)]) = do
      -- Get projection made in subject of case:
      [Int]
fTrace1 <- [Int] -> Term -> Term -> Maybe [Int]
stripProjection [Int]
fTrace0 Term
vTarget0 Term
v

      -- Extract projection of this case statement. Subsequent calls to
      -- 'stripProjection' will check if new target is actually used.
      (Int
n, [Int]
fTrace2) <- [Int] -> Maybe (Int, [Int])
forall a. [a] -> Maybe (a, [a])
List.uncons [Int]
fTrace1
      Var Term
vTarget1 <- [Var Term] -> Int -> Maybe (Var Term)
forall a. [a] -> Int -> Maybe a
List.indexMaybe [Var Term]
xs Int
n

      [Int] -> Term -> Term -> Maybe [Int]
stripProjection [Int]
fTrace2 (Var Term -> Term
Var Var Term
vTarget1) Term
r

    stripProjection [Int]
fTrace (Var Var Term
sTarget) (Var Var Term
s) =
      if Var Term
sTarget Var Term -> Var Term -> Bool
forall a. Eq a => a -> a -> Bool
== Var Term
s then [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
fTrace else Maybe [Int]
forall a. Maybe a
Nothing

    stripProjection [Int]
_fTrace Term
_vTarget Term
_v =
      Maybe [Int]
forall a. Maybe a
Nothing

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

-- | Inline a function with functional arguments
inlineHO :: HasCallStack => NormRewrite
inlineHO :: NormRewrite
inlineHO TransformContext
_ e :: Term
e@(App Term
_ Term
_)
  | (Var Var Term
f, [Either Term Kind]
args, [TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
e
  = 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
Lens' RewriteEnv TyConMap
tcCache
    let hasPolyFunArgs :: Bool
hasPolyFunArgs = [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or ((Either Term Kind -> Bool) -> [Either Term Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Bool) -> (Kind -> Bool) -> Either Term Kind -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TyConMap -> Term -> Bool
isPolyFun TyConMap
tcm) (Bool -> Kind -> Bool
forall a b. a -> b -> a
const Bool
False)) [Either Term Kind]
args)
    if Bool
hasPolyFunArgs
      then 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 (RewriteState NormalizeState) Int
-> RewriteMonad NormalizeState Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Int NormalizeState)
-> RewriteState NormalizeState
-> Const Int (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Int NormalizeState)
 -> RewriteState NormalizeState
 -> Const Int (RewriteState NormalizeState))
-> ((Int -> Const Int Int)
    -> NormalizeState -> Const Int NormalizeState)
-> Getting Int (RewriteState NormalizeState) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int)
-> NormalizeState -> Const Int NormalizeState
Lens' NormalizeState Int
inlineLimit)
              if (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
                then do
                  DebugLevel
lvl <- Getting DebugLevel RewriteEnv DebugLevel
-> RewriteMonad NormalizeState DebugLevel
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting DebugLevel RewriteEnv DebugLevel
Lens' RewriteEnv DebugLevel
dbgLevel
                  Bool
-> String
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. Bool -> String -> a -> a
traceIf (DebugLevel
lvl DebugLevel -> DebugLevel -> Bool
forall a. Ord a => a -> a -> Bool
> DebugLevel
DebugNone) ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"InlineHO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var Term -> String
forall a. Show a => a -> String
show Var Term
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" already inlined " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
limit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" times in:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var Term -> String
forall a. Show a => a -> String
show Var Term
cf) (Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e)
                else do
                  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
                  case Maybe (Binding Term)
bodyMaybe of
                    Just Binding Term
b -> do
                      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)
                      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (Binding Term -> Term
forall a. Binding a -> a
bindingTerm Binding Term
b) [TickInfo]
ticks) [Either Term Kind]
args)
                    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

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

-- | Simplified CSE, only works on let-bindings, does an inverse topological
-- sort of the let-bindings and then works from top to bottom
--
-- XXX: Check whether inverse top-sort followed by single traversal removes as
-- many binders as the previous "apply-until-fixpoint" approach in the presence
-- of recursive groups in the let-bindings. If not but just for checking whether
-- changes to transformation affect the eventual size of the circuit, it would
-- be really helpful if we tracked circuit size in the regression/test suite.
-- On the two examples that were tested, Reducer and PipelinesViaFolds, this new
-- version of CSE removed the same amount of let-binders.
simpleCSE :: HasCallStack => NormRewrite
simpleCSE :: NormRewrite
simpleCSE (TransformContext InScopeSet
is0 Context
_) (HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings -> Letrec [LetBinding]
bndrs Term
body) = do
  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]
bndrs)
  (Subst
subst,[LetBinding]
bndrs1) <- Subst
-> [LetBinding]
-> [LetBinding]
-> RewriteMonad NormalizeState (Subst, [LetBinding])
reduceBinders (InScopeSet -> Subst
mkSubst InScopeSet
is1) [] [LetBinding]
bndrs
  -- TODO: check whether a substitution over the body is enough, the reason I'm
  -- doing a substitution over the the binders as well is that I don't know in
  -- what order a recursive group shows up in a inverse topological sort.
  -- Depending on the order and forgetting to apply the substitution over the
  -- let-bindings might lead to the introduction of free variables.
  --
  -- NB: don't apply the substitution to the entire let-expression, and that
  -- would rename the let-bindings because they've been added to the InScopeSet
  -- of the substitution.
  let bndrs2 :: [LetBinding]
bndrs2 = (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"simpleCSE.bndrs" Subst
subst)) [LetBinding]
bndrs1
      body1 :: Term
body1  = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"simpleCSE.body" Subst
subst Term
body
  Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
Letrec [LetBinding]
bndrs2 Term
body1)

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

-- | XXX: is given inverse topologically sorted binders, but returns
-- topologically sorted binders
--
-- TODO: check further speed improvements:
--
-- 1. Store the processed binders in a `Map Expr LetBinding`:
--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:
--    * O(log n)*aeqTerm `insert` and O(log n)*aeqTerm `lookup`
-- 2. Store the processed binders in a `AEQTrie Expr LetBinding`
--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:
--    * O(e) `insert` and O(e) `lookup`
reduceBinders
  :: Subst
  -> [LetBinding]
  -> [LetBinding]
  -> RewriteMonad NormalizeState (Subst, [LetBinding])
reduceBinders :: Subst
-> [LetBinding]
-> [LetBinding]
-> RewriteMonad NormalizeState (Subst, [LetBinding])
reduceBinders !Subst
subst [LetBinding]
processed [] = (Subst, [LetBinding])
-> RewriteMonad NormalizeState (Subst, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Subst
subst,[LetBinding]
processed)
reduceBinders !Subst
subst [LetBinding]
processed ((Var Term
i,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"reduceBinders" Subst
subst -> Term
e):[LetBinding]
rest)
  | (Term
_,[Either Term Kind]
_,[TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
e
  , TickInfo
NoDeDup TickInfo -> [TickInfo] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`notElem` [TickInfo]
ticks
  , Just (Var Term
i1,Term
_) <- (LetBinding -> Bool) -> [LetBinding] -> Maybe LetBinding
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
List.find ((Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
e) (Term -> Bool) -> (LetBinding -> Term) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Term
forall a b. (a, b) -> b
snd) [LetBinding]
processed
  = do
    let subst1 :: Subst
subst1 = Subst -> Var Term -> Term -> Subst
extendIdSubst Subst
subst Var Term
i (Var Term -> Term
Var Var Term
i1)
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    Subst
-> [LetBinding]
-> [LetBinding]
-> RewriteMonad NormalizeState (Subst, [LetBinding])
reduceBinders Subst
subst1 [LetBinding]
processed [LetBinding]
rest
  | Bool
otherwise
  = Subst
-> [LetBinding]
-> [LetBinding]
-> RewriteMonad NormalizeState (Subst, [LetBinding])
reduceBinders Subst
subst ((Var Term
i,Term
e)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
processed) [LetBinding]
rest
{-# SCC reduceBinders #-}

reduceConst :: HasCallStack => NormRewrite
reduceConst :: NormRewrite
reduceConst TransformContext
ctx e :: Term
e@(App Term
_ Term
_)
  | (Prim PrimInfo
p0, [Either Term Kind]
_) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e
  = Bool
-> TransformContext
-> Term
-> NormRewrite
-> RewriteMonad NormalizeState Term
forall extra.
Bool
-> TransformContext
-> Term
-> Rewrite extra
-> RewriteMonad extra Term
whnfRW Bool
False TransformContext
ctx Term
e (NormRewrite -> RewriteMonad NormalizeState Term)
-> NormRewrite -> RewriteMonad NormalizeState Term
forall a b. (a -> b) -> a -> b
$ \TransformContext
_ctx1 Term
e1 -> case Term
e1 of
      (Term -> (Term, [Either Term Kind])
collectArgs -> (Prim PrimInfo
p1, [Either Term Kind]
_)) | PrimInfo -> Text
primName PrimInfo
p0 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== PrimInfo -> Text
primName PrimInfo
p1 -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Term
_ -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1

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

-- | Replace primitives by their "definition" if they would lead to let-bindings
-- with a non-representable type when a function is in ANF. This happens for
-- example when Clash.Size.Vector.map consumes or produces a vector of
-- non-representable elements.
--
-- Basically what this transformation does is replace a primitive the completely
-- unrolled recursive definition that it represents. e.g.
--
-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int)
--
-- is replaced by:
--
-- > let (x0  :: (Int -> Int))       = case xs  of (:>) _ x xr -> x
-- >     (xr0 :: Vec 1 (Int -> Int)) = case xs  of (:>) _ x xr -> xr
-- >     (x1  :: (Int -> Int)(       = case xr0 of (:>) _ x xr -> x
-- >     (y0  :: Int)                = case ys  of (:>) _ y yr -> y
-- >     (yr0 :: Vec 1 Int)          = case ys  of (:>) _ y yr -> xr
-- >     (y1  :: Int                 = case yr0 of (:>) _ y yr -> y
-- > in  (($) x0 y0 :> ($) x1 y1 :> Nil)
--
-- Currently, it only handles the following functions:
--
-- * Clash.Sized.Vector.zipWith
-- * Clash.Sized.Vector.map
-- * Clash.Sized.Vector.traverse#
-- * Clash.Sized.Vector.fold
-- * Clash.Sized.Vector.foldr
-- * Clash.Sized.Vector.dfold
-- * Clash.Sized.Vector.(++)
-- * Clash.Sized.Vector.head
-- * Clash.Sized.Vector.tail
-- * Clash.Sized.Vector.last
-- * Clash.Sized.Vector.init
-- * Clash.Sized.Vector.unconcat
-- * Clash.Sized.Vector.transpose
-- * Clash.Sized.Vector.replicate
-- * Clash.Sized.Vector.replace_int
-- * Clash.Sized.Vector.imap
-- * Clash.Sized.Vector.dtfold
-- * Clash.Sized.RTree.tdfold
-- * Clash.Sized.RTree.treplicate
-- * Clash.Sized.Internal.BitVector.split#
-- * Clash.Sized.Internal.BitVector.eq#
--
-- Note [Unroll shouldSplit types]
-- 1. Certain higher-order functions over Vec, such as map, have specialized
-- code-paths to turn them into generate-for loops in HDL, instead of having to
-- having to unroll/inline their recursive definitions, e.g. Clash.Sized.Vector.map
--
-- 2. Clash, in general, translates Haskell product types to VHDL records. This
-- mostly works out fine, there is however one exception: certain synthesis
-- tools, and some HDL simulation tools (like verilator), do not like it when
-- the clock (and certain other global control signals) is contained in a
-- record type; they want them to be separate inputs to the entity/module.
-- And Clash actually does some transformations to try to ensure that values of
-- type Clock do not end up in a VHDL record type.
--
-- The problem is that the transformations in 2. never took into account the
-- specialized code-paths in 1. Making the code-paths in 1. aware of the
-- transformations in 2. is really not worth the effort for such a niche case.
-- It's easier to just unroll the recursive definitions.
--
-- See https://github.com/clash-lang/clash-compiler/issues/1606
reduceNonRepPrim :: HasCallStack => NormRewrite
reduceNonRepPrim :: NormRewrite
reduceNonRepPrim c :: TransformContext
c@(TransformContext InScopeSet
is0 Context
ctx) e :: Term
e@(App Term
_ Term
_) | (Prim PrimInfo
p, [Either Term Kind]
args, [TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
e = 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
Lens' RewriteEnv TyConMap
tcCache
  Bool
ultra <- Getting Bool (RewriteState NormalizeState) Bool
-> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState -> Const Bool NormalizeState)
-> RewriteState NormalizeState
-> Const Bool (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState -> Const Bool NormalizeState)
 -> RewriteState NormalizeState
 -> Const Bool (RewriteState NormalizeState))
-> ((Bool -> Const Bool Bool)
    -> NormalizeState -> Const Bool NormalizeState)
-> Getting Bool (RewriteState NormalizeState) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> Const Bool Bool)
-> NormalizeState -> Const Bool NormalizeState
Lens' NormalizeState Bool
normalizeUltra)
  let eTy :: Kind
eTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e
  case Kind -> TypeView
tyView Kind
eTy of
    (TyConApp vecTcNm :: TyConName
vecTcNm@(TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
"Clash.Sized.Vector.Vec")
              [Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (Except String Integer -> Either String Integer)
-> (Kind -> Except String Integer) -> Kind -> Either String Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm -> Right Integer
0, Kind
aTy]) -> do
      let (Just TyCon
vecTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
vecTcNm TyConMap
tcm
          [DataCon
nilCon,DataCon
consCon] = TyCon -> [DataCon]
tyConDataCons TyCon
vecTc
          nilE :: Term
nilE = DataCon -> DataCon -> Kind -> Integer -> [Term] -> Term
mkVec DataCon
nilCon DataCon
consCon Kind
aTy Integer
0 []
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
nilE [TickInfo]
ticks)
    TypeView
tv -> let argLen :: Int
argLen = [Either Term Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Either Term Kind]
args in case PrimInfo -> Text
primName PrimInfo
p of
      Text
"Clash.Sized.Vector.zipWith" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 -> do
        let [Kind
lhsElTy,Kind
rhsElty,Kind
resElTy,Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            TyConApp TyConName
vecTcNm [Kind]
_ = TypeView
tv
            lhsTy :: Kind
lhsTy = TyConName -> [Kind] -> Kind
mkTyConApp TyConName
vecTcNm [Kind
nTy,Kind
lhsElTy]
            rhsTy :: Kind
rhsTy = TyConName -> [Kind] -> Kind
mkTyConApp TyConName
vecTcNm [Kind
nTy,Kind
rhsElty]
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , (Kind -> RewriteMonad NormalizeState Bool)
-> [Kind] -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
List.anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly
                                        [Kind
lhsElTy,Kind
rhsElty,Kind
resElTy]
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Kind -> Bool) -> [Kind] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool)
-> (Kind -> Maybe ([Term] -> Term, Projections, [Kind]))
-> Kind
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm)
                                             [Kind
lhsTy,Kind
rhsTy,Kind
eTy]) ]
            if Bool
shouldReduce1
               then let [Term
fun,Term
lhsArg,Term
rhsArg] = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
                    in  (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        TransformContext
-> PrimInfo
-> Integer
-> Kind
-> Kind
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceZipWith TransformContext
c PrimInfo
p Integer
n Kind
lhsElTy Kind
rhsElty Kind
resElTy Term
fun Term
lhsArg Term
rhsArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.map" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> do
        let [Kind
argElTy,Kind
resElTy,Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            TyConApp TyConName
vecTcNm [Kind]
_ = TypeView
tv
            argTy :: Kind
argTy = TyConName -> [Kind] -> Kind
mkTyConApp TyConName
vecTcNm [Kind
nTy,Kind
argElTy]
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 )
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , (Kind -> RewriteMonad NormalizeState Bool)
-> [Kind] -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
List.anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly
                                        [Kind
argElTy,Kind
resElTy]
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Kind -> Bool) -> [Kind] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool)
-> (Kind -> Maybe ([Term] -> Term, Projections, [Kind]))
-> Kind
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm)
                                             [Kind
argTy,Kind
eTy]) ]
            if Bool
shouldReduce1
               then let [Term
fun,Term
arg] = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
                    in  (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> PrimInfo
-> Integer
-> Kind
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceMap TransformContext
c PrimInfo
p Integer
n Kind
argElTy Kind
resElTy Term
fun Term
arg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.traverse#" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 ->
        let [Kind
aTy,Kind
fTy,Kind
bTy,Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
        in  case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n ->
            let [Term
dict,Term
fun,Term
arg] = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
            in  (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> Integer
-> Kind
-> Kind
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceTraverse TransformContext
c Integer
n Kind
aTy Kind
fTy Kind
bTy Term
dict Term
fun Term
arg
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.fold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> do
        let ([Term
fun,Term
arg],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
            argTy :: Kind
argTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
arg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy))]
            if Bool
shouldReduce1 then
              (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> Integer
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceFold TransformContext
c (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Kind
aTy Term
fun Term
arg
            else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.foldr" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 ->
        let ([Term
fun,Term
start,Term
arg],[Kind
aTy,Kind
bTy,Kind
nTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
            argTy :: Kind
argTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
arg
        in  case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , (Kind -> RewriteMonad NormalizeState Bool)
-> [Kind] -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
List.anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly [Kind
aTy,Kind
bTy]
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy)) ]
            if Bool
shouldReduce1
              then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> PrimInfo
-> Integer
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceFoldr TransformContext
c PrimInfo
p Integer
n Kind
aTy Term
fun Term
start Term
arg
              else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.dfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 ->
        let ([Term
_kn,Term
_motive,Term
fun,Term
start,Term
arg],[Kind
_mTy,Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        in  case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceDFold InScopeSet
is0 Integer
n Kind
aTy Term
fun Term
start Term
arg
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.++" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 ->
        let [Kind
nTy,Kind
aTy,Kind
mTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [Term
lArg,Term
rArg]   = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
        in case (Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy), Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
mTy)) of
              (Right Integer
n, Right Integer
m)
                | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
rArg
                | Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
lArg
                | Bool
otherwise -> do
                    Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                         , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                         -- Note [Unroll shouldSplit types]
                                         , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
eTy)) ]
                    if Bool
shouldReduce1
                       then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Integer
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceAppend InScopeSet
is0 Integer
n Integer
m Kind
aTy Term
lArg Term
rArg
                       else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
              (Either String Integer, Either String Integer)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.head" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> do
        let [Kind
nTy,Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
            argTy :: Kind
argTy     = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
vArg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy)) ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceHead InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.tail" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> do
        let [Kind
nTy,Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
            argTy :: Kind
argTy     = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
vArg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy)) ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceTail InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.last" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> do
        let [Kind
nTy,Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
            argTy :: Kind
argTy     = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
vArg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy))
                                 ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceLast InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.init" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> do
        let [Kind
nTy,Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
            argTy :: Kind
argTy     = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
vArg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy)) ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> PrimInfo
-> Integer
-> Kind
-> Term
-> RewriteMonad NormalizeState Term
reduceInit InScopeSet
is0 PrimInfo
p Integer
n Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.unconcat" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> do
        let ([Term
_knN,Term
_sm,Term
arg],[Kind
mTy,Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case (Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy), Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
mTy)) of
          (Right Integer
n, Right Integer
0) -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceUnconcat Integer
n Integer
0 Kind
aTy Term
arg
          (Either String Integer, Either String Integer)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.transpose" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> do
        let ([Term
_knN,Term
arg],[Kind
mTy,Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case (Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy), Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
mTy)) of
          (Right Integer
n, Right Integer
0) -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceTranspose Integer
n Integer
0 Kind
aTy Term
arg
          (Either String Integer, Either String Integer)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.replicate" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> do
        let ([Term
_sArg,Term
vArg],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
eTy))
                                 ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Kind -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceReplicate Integer
n Kind
aTy Kind
eTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
       -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a
      Text
"Clash.Sized.Vector.replace_int" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> do
        let ([Term
_knArg,Term
vArg,Term
iArg,Term
aArg],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
eTy))
                                 ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Kind
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceReplace_int InScopeSet
is0 Integer
n Kind
aTy Kind
eTy Term
vArg Term
iArg Term
aArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      Text
"Clash.Sized.Vector.index_int" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> do
        let ([Term
_knArg,Term
vArg,Term
iArg],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
            argTy :: Kind
argTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
vArg
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
ultra
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy)) ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceIndex_int InScopeSet
is0 Integer
n Kind
aTy Term
vArg Term
iArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      Text
"Clash.Sized.Vector.imap" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> do
        let [Kind
nTy,Kind
argElTy,Kind
resElTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            TyConApp TyConName
vecTcNm [Kind]
_ = TypeView
tv
            argTy :: Kind
argTy = TyConName -> [Kind] -> Kind
mkTyConApp TyConName
vecTcNm [Kind
nTy,Kind
argElTy]
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , (Kind -> RewriteMonad NormalizeState Bool)
-> [Kind] -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
List.anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly [Kind
argElTy,Kind
resElTy]
                                 -- Note [Unroll shouldSplit types]
                                 , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Kind -> Bool) -> [Kind] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool)
-> (Kind -> Maybe ([Term] -> Term, Projections, [Kind]))
-> Kind
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm)
                                             [Kind
argTy,Kind
eTy]) ]
            if Bool
shouldReduce1
               then let [Term
_,Term
fun,Term
arg] = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args
                    in  (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> Integer
-> Kind
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceImap TransformContext
c Integer
n Kind
argElTy Kind
resElTy Term
fun Term
arg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.iterateI" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 ->
        let ([Term
_kn,Term
f,Term
a],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args in
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM
              [ Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2)
              , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
              , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy
              -- Note [Unroll shouldSplit types]
              , Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe ([Term] -> Term, Projections, [Kind]) -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
eTy)) ]

            if Bool
shouldReduce1 then
              (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TransformContext
-> Integer
-> Kind
-> Kind
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceIterateI TransformContext
c Integer
n Kind
aTy Kind
eTy Term
f Term
a
            else
              Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Vector.dtfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 ->
        let ([Term
_kn,Term
_motive,Term
lrFun,Term
brFun,Term
arg],[Kind
_mTy,Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        in  case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceDTFold InScopeSet
is0 Integer
n Kind
aTy Term
lrFun Term
brFun Term
arg
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      Text
"Clash.Sized.Vector.reverse"
        | Bool
ultra
        , ([Term
vArg],[Kind
nTy,Kind
aTy]) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        , Right Integer
n <- Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy)
        -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceReverse InScopeSet
is0 Integer
n Kind
aTy Term
vArg

      Text
"Clash.Sized.RTree.tdfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 ->
        let ([Term
_kn,Term
_motive,Term
lrFun,Term
brFun,Term
arg],[Kind
_mTy,Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        in  case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> InScopeSet
-> Integer
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceTFold InScopeSet
is0 Integer
n Kind
aTy Term
lrFun Term
brFun Term
arg
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.RTree.treplicate" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> do
        let ([Term
_sArg,Term
vArg],[Kind
nTy,Kind
aTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy) of
          Right Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
List.orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Bool -> Kind -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Kind -> RewriteMonad extra Bool
isUntranslatableType Bool
False Kind
aTy ]
            if Bool
shouldReduce1
               then (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks) (Term -> Term)
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Kind -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceTReplicate Integer
n Kind
aTy Kind
eTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          Either String Integer
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Internal.BitVector.split#" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> do
        let ([Term
_knArg,Term
bvArg],[Kind
nTy,Kind
mTy]) = [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        case (Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy), Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
mTy), TypeView
tv) of
          (Right Integer
n, Right Integer
m, TyConApp TyConName
tupTcNm [Kind
lTy,Kind
rTy])
            | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> do
              let (Just TyCon
tupTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tupTcNm TyConMap
tcm
                  [DataCon
tupDc]      = TyCon -> [DataCon]
tyConDataCons TyCon
tupTc
                  tup :: Term
tup          = Term -> [Either Term Kind] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc)
                                    [Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
lTy
                                    ,Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
rTy
                                    ,Term -> Either Term Kind
forall a b. a -> Either a b
Left  Term
bvArg
                                    ,Term -> Either Term Kind
forall a b. a -> Either a b
Left  (Kind -> Term
removedTm Kind
rTy)
                                    ]

              Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
tup [TickInfo]
ticks)
            | Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> do
              let (Just TyCon
tupTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tupTcNm TyConMap
tcm
                  [DataCon
tupDc]      = TyCon -> [DataCon]
tyConDataCons TyCon
tupTc
                  tup :: Term
tup          = Term -> [Either Term Kind] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc)
                                    [Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
lTy
                                    ,Kind -> Either Term Kind
forall a b. b -> Either a b
Right Kind
rTy
                                    ,Term -> Either Term Kind
forall a b. a -> Either a b
Left  (Kind -> Term
removedTm Kind
lTy)
                                    ,Term -> Either Term Kind
forall a b. a -> Either a b
Left  Term
bvArg
                                    ]

              Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
tup [TickInfo]
ticks)
          (Either String Integer, Either String Integer, TypeView)
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      Text
"Clash.Sized.Internal.BitVector.eq#"
        | ([Term
_,Term
_],[Kind
nTy]) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        , Right Integer
0 <- Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Kind -> Except String Integer
tyNatSize TyConMap
tcm Kind
nTy)
        , TyConApp TyConName
boolTcNm [] <- TypeView
tv
        -> let (Just TyCon
boolTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
boolTcNm TyConMap
tcm
               [DataCon
_falseDc,DataCon
trueDc] = TyCon -> [DataCon]
tyConDataCons TyCon
boolTc
           in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks (DataCon -> Term
Data DataCon
trueDc) [TickInfo]
ticks)
      Text
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
  where
    isUntranslatableType_not_poly :: Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
t = do
      Bool
u <- Bool -> Kind -> RewriteMonad extra Bool
forall extra. Bool -> Kind -> RewriteMonad extra Bool
isUntranslatableType Bool
False Kind
t
      if Bool
u
         then Bool -> RewriteMonad extra Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([TyVar] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([TyVar] -> Bool) -> [TyVar] -> Bool
forall a b. (a -> b) -> a -> b
$ Getting (Endo [TyVar]) Kind TyVar -> Kind -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Kind TyVar
Fold Kind TyVar
typeFreeVars Kind
t)
         else Bool -> RewriteMonad extra Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

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

-- | This transformation lifts applications of global binders out of
-- alternatives of case-statements.
--
-- e.g. It converts:
--
-- @
-- case x of
--   A -> f 3 y
--   B -> f x x
--   C -> h x
-- @
--
-- into:
--
-- @
-- let f_arg0 = case x of {A -> 3; B -> x}
--     f_arg1 = case x of {A -> y; B -> x}
--     f_out  = f f_arg0 f_arg1
-- in  case x of
--       A -> f_out
--       B -> f_out
--       C -> h x
-- @
disjointExpressionConsolidation :: HasCallStack => NormRewrite
disjointExpressionConsolidation :: NormRewrite
disjointExpressionConsolidation ctx :: TransformContext
ctx@(TransformContext InScopeSet
isCtx Context
_) e :: Term
e@(Case Term
_scrut Kind
_ty _alts :: [Alt]
_alts@(Alt
_:Alt
_:[Alt]
_)) = do
    -- Collect all (the applications of) global binders (and certain primitives)
    -- that would be interesting to share out of the case-alternatives.
    (Term
_,InScopeSet
isCollected,[(Term, ([Term], CaseTree [Either Term Kind]))]
collected) <- InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
isCtx [] [] Term
e
    -- Filter those that are used at most once in every (nested) branch.
    let disJoint :: [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint = ((Term, ([Term], CaseTree [Either Term Kind])) -> Bool)
-> [(Term, ([Term], CaseTree [Either Term Kind]))]
-> [(Term, ([Term], CaseTree [Either Term Kind]))]
forall a. (a -> Bool) -> [a] -> [a]
filter (CaseTree [Either Term Kind] -> Bool
isDisjoint (CaseTree [Either Term Kind] -> Bool)
-> ((Term, ([Term], CaseTree [Either Term Kind]))
    -> CaseTree [Either Term Kind])
-> (Term, ([Term], CaseTree [Either Term Kind]))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Term], CaseTree [Either Term Kind])
-> CaseTree [Either Term Kind]
forall a b. (a, b) -> b
snd (([Term], CaseTree [Either Term Kind])
 -> CaseTree [Either Term Kind])
-> ((Term, ([Term], CaseTree [Either Term Kind]))
    -> ([Term], CaseTree [Either Term Kind]))
-> (Term, ([Term], CaseTree [Either Term Kind]))
-> CaseTree [Either Term Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, ([Term], CaseTree [Either Term Kind]))
-> ([Term], CaseTree [Either Term Kind])
forall a b. (a, b) -> b
snd) [(Term, ([Term], CaseTree [Either Term Kind]))]
collected
    if [(Term, ([Term], CaseTree [Either Term Kind]))] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint
       then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
       else do
         -- For every to-lift expression create (the generalization of):
         --
         -- let fargs = case x of {A -> (3,y); B -> (x,x)}
         -- in  f (fst fargs) (snd fargs)
         --
         -- the let-expression is not created when `f` has only one (selectable)
         -- argument
         --
         -- NB: mkDisJointGroup needs the context InScopeSet, isCtx, to determine
         -- whether expressions reference variables from the context, or
         -- variables inside a let-expression inside one of the alternatives.
         [(Term, [Term])]
lifted <- ((Term, ([Term], CaseTree [Either Term Kind]))
 -> RewriteMonad NormalizeState (Term, [Term]))
-> [(Term, ([Term], CaseTree [Either Term Kind]))]
-> RewriteMonad NormalizeState [(Term, [Term])]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InScopeSet
-> (Term, ([Term], CaseTree [Either Term Kind]))
-> RewriteMonad NormalizeState (Term, [Term])
mkDisjointGroup InScopeSet
isCtx) [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint
         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
Lens' RewriteEnv TyConMap
tcCache
         -- Create let-binders for all of the lifted expressions
         --
         -- NB: Because we will be substituting under binders we use the collected
         -- inScopeSet, isCollected, which also contains all the binders
         -- created inside all of the alternatives. With this inScopeSet, we
         -- ensure that the let-bindings we create here won't be accidentally
         -- captured by binders inside the case-alternatives.
         (InScopeSet
_,[Var Term]
funOutIds) <- (InScopeSet
 -> ((Term, ([Term], CaseTree [Either Term Kind])), (Term, [Term]))
 -> RewriteMonad NormalizeState (InScopeSet, Var Term))
-> InScopeSet
-> [((Term, ([Term], CaseTree [Either Term Kind])),
     (Term, [Term]))]
-> RewriteMonad NormalizeState (InScopeSet, [Var Term])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (TyConMap
-> InScopeSet
-> ((Term, ([Term], CaseTree [Either Term Kind])), (Term, [Term]))
-> RewriteMonad NormalizeState (InScopeSet, Var Term)
forall (m :: Type -> Type) b b.
MonadUnique m =>
TyConMap
-> InScopeSet -> ((Term, b), (Term, b)) -> m (InScopeSet, Var Term)
mkFunOut TyConMap
tcm)
                                          InScopeSet
isCollected
                                          ([(Term, ([Term], CaseTree [Either Term Kind]))]
-> [(Term, [Term])]
-> [((Term, ([Term], CaseTree [Either Term Kind])),
     (Term, [Term]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint [(Term, [Term])]
lifted)
         -- Create "substitutions" of the form [f X Y := f_out]
         let substitution :: [(Term, Term)]
substitution = [Term] -> [Term] -> [(Term, Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Term, ([Term], CaseTree [Either Term Kind])) -> Term)
-> [(Term, ([Term], CaseTree [Either Term Kind]))] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Term, ([Term], CaseTree [Either Term Kind])) -> Term
forall a b. (a, b) -> a
fst [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint) ((Var Term -> Term) -> [Var Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Var Term -> Term
Var [Var Term]
funOutIds)
         -- For all of the lifted expression: substitute occurrences of the
         -- disjoint expressions (f X Y) by a variable reference to the lifted
         -- expression (f_out)
         let isCtx1 :: InScopeSet
isCtx1 = InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
isCtx [Var Term]
funOutIds
         [Term]
lifted1 <- InScopeSet
-> [(Term, Term)]
-> [(Term, [Term])]
-> RewriteMonad NormalizeState [Term]
substLifted InScopeSet
isCtx1 [(Term, Term)]
substitution [(Term, [Term])]
lifted
         -- Do the same for the actual case expression
         (Term
e1,InScopeSet
_,[(Term, ([Term], CaseTree [Either Term Kind]))]
_) <- InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
isCtx1 [(Term, Term)]
substitution [] Term
e
         -- Let-bind all the lifted function
         let lb :: Term
lb = [LetBinding] -> Term -> Term
Letrec ([Var Term] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var Term]
funOutIds [Term]
lifted1) Term
e1
         -- Do an initial dead-code elimination pass, as `mkDisJoint` doesn't
         -- clean-up unused let-binders.
         Term
lb1 <- NormRewrite -> NormRewrite
forall (m :: Type -> Type). Monad m => Transform m -> Transform m
bottomupR HasCallStack => NormRewrite
NormRewrite
deadCode TransformContext
ctx Term
lb
         Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
lb1
  where
    -- Make the let-binder for the lifted expressions
    mkFunOut :: TyConMap
-> InScopeSet -> ((Term, b), (Term, b)) -> m (InScopeSet, Var Term)
mkFunOut TyConMap
tcm InScopeSet
isN ((Term
fun,b
_),(Term
eLifted,b
_)) = do
      let ty :: Kind
ty  = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
eLifted
          nm :: Text
nm  = case Term -> (Term, [Either Term Kind])
collectArgs Term
fun of
                   (Var Var Term
v,[Either Term Kind]
_)  -> Name Term -> Text
forall a. Name a -> Text
nameOcc (Var Term -> Name Term
forall a. Var a -> Name a
varName Var Term
v)
                   (Prim PrimInfo
p,[Either Term Kind]
_) -> PrimInfo -> Text
primName PrimInfo
p
                   (Term, [Either Term Kind])
_          -> Text
"complex_expression_"
          nm1 :: Text
nm1 = [Text] -> Text
forall a. [a] -> a
last (Text -> Text -> [Text]
Text.splitOn Text
"." Text
nm) Text -> Text -> Text
`Text.append` Text
"Out"
      Var Term
nm2 <- InScopeSet -> Text -> Kind -> m (Var Term)
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m (Var Term)
mkInternalVar InScopeSet
isN Text
nm1 Kind
ty
      (InScopeSet, Var Term) -> m (InScopeSet, Var Term)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (InScopeSet -> Var Term -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isN Var Term
nm2,Var Term
nm2)

    -- Substitute inside the lifted expressions
    --
    -- In case you are wondering why this function isn't simply
    --
    -- > mapM (\s (eL,seen) -> collectGlobal isN s seen eL) substitution lifted
    --
    -- then that's because we have e.g. the list of "substitutions":
    --
    -- [foo _ _ := foo_out; bar _ _ := bar_out]
    --
    -- and if we were to apply that to a lifted expression, which is going
    -- to be of the form `foo (case ...) (case ...)` then we would end up
    -- with let-bindings that are simply:
    --
    -- > let foo_out = foo_out ; bar_out = bar_out
    --
    -- instead of the desired
    --
    -- > let foo_out = foo ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])
    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])
    -- >     bar_out = bar ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])
    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])
    --
    -- So what we do is that for every lifted-expression we make sure that the
    -- 'substitution' never contains the self-substitution, so we end up with:
    --
    -- > let foo_out = (foo (case ...) (case ...))[bar _ _ := bar_out]
    --       bar_out = (bar (case ...) (case ...))[foo _ _ := foo_out]
    --
    -- We used to have a different approach, see commit
    -- 73d237017c4a5fff0c49bb72c9c4d5f6c68faf69
    --
    -- But that lead to the generation of combinational loops. Now that we no
    -- longer traverse into recursive groups of let-bindings, the issue #1316
    -- that the above commit tried to solve, no longer shows up.
    substLifted :: InScopeSet
-> [(Term, Term)]
-> [(Term, [Term])]
-> RewriteMonad NormalizeState [Term]
substLifted InScopeSet
isN [(Term, Term)]
substitution [(Term, [Term])]
lifted = do
      -- remove the self-substitutions for the respective lifted expressions
      let subsMatrix :: [[(Term, Term)]]
subsMatrix = [(Term, Term)] -> [[(Term, Term)]]
forall a. [a] -> [[a]]
l2m [(Term, Term)]
substitution
      [(Term, InScopeSet,
  [(Term, ([Term], CaseTree [Either Term Kind]))])]
lifted1 <- ([(Term, Term)]
 -> (Term, [Term])
 -> RewriteMonad
      NormalizeState
      (Term, InScopeSet,
       [(Term, ([Term], CaseTree [Either Term Kind]))]))
-> [[(Term, Term)]]
-> [(Term, [Term])]
-> RewriteMonad
     NormalizeState
     [(Term, InScopeSet,
       [(Term, ([Term], CaseTree [Either Term Kind]))])]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
Monad.zipWithM (\[(Term, Term)]
s (Term
eL,[Term]
seen) -> InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
isN [(Term, Term)]
s [Term]
seen Term
eL)
                                 [[(Term, Term)]]
subsMatrix
                                 [(Term, [Term])]
lifted
      [Term] -> RewriteMonad NormalizeState [Term]
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Term, InScopeSet,
  [(Term, ([Term], CaseTree [Either Term Kind]))])
 -> Term)
-> [(Term, InScopeSet,
     [(Term, ([Term], CaseTree [Either Term Kind]))])]
-> [Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
-> Getting
     Term
     (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
     Term
-> Term
forall s a. s -> Getting a s a -> a
^. Getting
  Term
  (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Kind]))])
  Term
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(Term, InScopeSet,
  [(Term, ([Term], CaseTree [Either Term Kind]))])]
lifted1)

    l2m :: [a] -> [[a]]
l2m = [a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
go []
     where
      go :: [a] -> [a] -> [[a]]
go [a]
_  []     = []
      go [a]
xs (a
y:[a]
ys) = ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
go ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
y]) [a]
ys

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

-- | 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
  HashMap Text GuardedCompiledPrimitive
prims <- Getting
  (HashMap Text GuardedCompiledPrimitive)
  (RewriteState NormalizeState)
  (HashMap Text GuardedCompiledPrimitive)
-> RewriteMonad
     NormalizeState (HashMap Text GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState
 -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
-> RewriteState NormalizeState
-> Const
     (HashMap Text GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra((NormalizeState
  -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
 -> RewriteState NormalizeState
 -> Const
      (HashMap Text GuardedCompiledPrimitive)
      (RewriteState NormalizeState))
-> ((HashMap Text GuardedCompiledPrimitive
     -> Const
          (HashMap Text GuardedCompiledPrimitive)
          (HashMap Text GuardedCompiledPrimitive))
    -> NormalizeState
    -> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState)
-> Getting
     (HashMap Text GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
     (HashMap Text GuardedCompiledPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(HashMap Text GuardedCompiledPrimitive
 -> Const
      (HashMap Text GuardedCompiledPrimitive)
      (HashMap Text GuardedCompiledPrimitive))
-> NormalizeState
-> Const (HashMap Text GuardedCompiledPrimitive) NormalizeState
Lens' NormalizeState (HashMap Text GuardedCompiledPrimitive)
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 :: VarSet
bodyFVs   = Getting VarSet Term (Var Term)
-> (Var Term -> VarSet) -> Term -> VarSet
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting VarSet Term (Var Term)
Fold Term (Var Term)
freeLocalIds Var Term -> VarSet
forall a. Var a -> VarSet
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
-> HashMap Text GuardedCompiledPrimitive
-> VarSet
-> (Var Term, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs HashMap Text GuardedCompiledPrimitive
prims VarSet
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
-> HashMap Text GuardedCompiledPrimitive
-> VarSet
-> (Var Term, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs HashMap Text GuardedCompiledPrimitive
prims VarSet
bodyFVs (Var Term
id_,((Var Term
_,((Term, [Either Term Kind]) -> Term
forall a b. (a, b) -> a
fst((Term, [Either Term Kind]) -> Term)
-> (Term -> (Term, [Either Term Kind])) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Term -> (Term, [Either Term Kind])
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 -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`notElemVarSet` VarSet
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
-> HashMap Text GuardedCompiledPrimitive
-> Maybe GuardedCompiledPrimitive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm HashMap Text GuardedCompiledPrimitive
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
_ Kind
_ [Alt
_] -> Bool
True
          Data DataCon
_ -> Bool
True
          Case Term
_ Kind
aTy (Alt
_:Alt
_:[Alt]
_)
            | TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
"Clash.Explicit.SimIO.SimIO") [Kind]
_ <- Kind -> TypeView
tyView Kind
aTy
            -> Bool
True
          Term
_ -> Bool
False
      | Var Term
id_ Var Term -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`notElemVarSet` VarSet
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` [ Text
"Clash.Explicit.SimIO.openFile"
                        , Text
"Clash.Explicit.SimIO.fgetc"
                        , Text
"Clash.Explicit.SimIO.feof"
                        ]
            , 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
_ Kind
_ [(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
== Text
"Clash.Sized.Internal.BitVector.BV"  Bool -> Bool -> Bool
||
                  Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Clash.Sized.Internal.BitVector.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
_ Kind
aTy (Alt
_:Alt
_:[Alt]
_)
            | TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
"Clash.Explicit.SimIO.SimIO") [Kind]
_ <- Kind -> TypeView
tyView Kind
aTy
            -> Bool
True
          Term
_ -> Bool
False

    isInteresting VarEnv Int
_ HashMap Text GuardedCompiledPrimitive
_ VarSet
_ (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 #-}

-- | Mark to track progress of 'reduceBindersCleanup'
data Mark = Temp | Done | Rec

-- | 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 #-}

-- | 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
          String
-> (Maybe Subst, VarEnv Int, VarEnv (LetBinding, VarEnv Int, Mark))
forall a. HasCallStack => String -> 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 #-}

-- | Flatten's letrecs after `inlineCleanup`
--
-- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`,
-- which then introduces let-bindings in what should be ANF. This transformation
-- flattens those nested let-bindings again.
--
-- NB: must only be called in the cleaning up phase.
flattenLet :: HasCallStack => NormRewrite
flattenLet :: NormRewrite
flattenLet (TransformContext InScopeSet
is0 Context
_) (Letrec [LetBinding]
binds Term
body) = do
  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)
      bodyOccs :: VarEnv Int
bodyOccs = Fold Term (Var Term)
-> (VarEnv Int -> VarEnv Int -> VarEnv Int)
-> VarEnv Int
-> (Var Term -> VarEnv Int)
-> Term
-> VarEnv Int
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
Lens.foldMapByOf
                   Fold Term (Var Term)
freeLocalIds ((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 (Var Term -> Int -> VarEnv Int
forall b a. Var b -> a -> VarEnv a
`unitVarEnv` (Int
1 :: Int))
                   Term
body
  (InScopeSet
is2,[LetBinding]
binds1) <- ([[LetBinding]] -> [LetBinding])
-> (InScopeSet, [[LetBinding]]) -> (InScopeSet, [LetBinding])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [[LetBinding]] -> [LetBinding]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((InScopeSet, [[LetBinding]]) -> (InScopeSet, [LetBinding]))
-> RewriteMonad NormalizeState (InScopeSet, [[LetBinding]])
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (InScopeSet
 -> LetBinding
 -> RewriteMonad NormalizeState (InScopeSet, [LetBinding]))
-> InScopeSet
-> [LetBinding]
-> RewriteMonad NormalizeState (InScopeSet, [[LetBinding]])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM InScopeSet
-> LetBinding
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
go InScopeSet
is1 [LetBinding]
binds
  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
  Bool
e1WorkFree <-
    case [LetBinding]
binds1 of
      [(Var Term
_,Term
e1)] -> Lens' (RewriteState NormalizeState) (VarEnv Bool)
-> VarEnv (Binding Term)
-> Term
-> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState NormalizeState) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
e1
      [LetBinding]
_ -> Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Bool
forall a. HasCallStack => String -> a
error String
"flattenLet: unreachable")
  case [LetBinding]
binds1 of
    -- inline binders into the body when there's only a single binder, and only
    -- if that binder doesn't perform any work or is only used once in the body
    [(Var Term
id1,Term
e1)] | Just Int
occ <- Var Term -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Var Term
id1 VarEnv Int
bodyOccs, Bool
e1WorkFree Bool -> Bool -> Bool
|| Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 ->
      if Var Term
id1 Var Term -> Term -> Bool
`localIdOccursIn` Term
e1
         -- Except when the binder is recursive!
         then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds1 Term
body)
         else let subst :: Subst
subst = Subst -> Var Term -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is2) Var Term
id1 Term
e1
              in Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"flattenLet" Subst
subst Term
body)
    [LetBinding]
_ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds1 Term
body)
  where
    go :: InScopeSet -> LetBinding -> NormalizeSession (InScopeSet,[LetBinding])
    go :: InScopeSet
-> LetBinding
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
go InScopeSet
isN (Var Term
id1,Term -> (Term, [TickInfo])
collectTicks -> (Letrec [LetBinding]
binds1 Term
body1,[TickInfo]
ticks)) = do
      let bs1 :: [Var Term]
bs1 = (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]
binds1
      let ([LetBinding]
binds2,Term
body2,InScopeSet
isN1) =
            -- We need to deshadow because we're merging nested let-expressions
            -- into a single let-expression: and within a let-expression, the
            -- bindings are not allowed to shadow each-other. Of course, we
            -- only need to deshadow if any shadowing is happening in the
            -- first place.
            --
            -- This is much better than blindly calling freshenTm, and saves
            -- almost 30% run-time of the normalization phase on some examples.
            if (Var Term -> Bool) -> [Var Term] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Var Term -> InScopeSet -> Bool
forall a. Var a -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
isN) [Var Term]
bs1 then
              let Letrec [LetBinding]
bindsN Term
bodyN = HasCallStack => InScopeSet -> Term -> Term
InScopeSet -> Term -> Term
deShadowTerm InScopeSet
isN ([LetBinding] -> Term -> Term
Letrec [LetBinding]
binds1 Term
body1)
              in  ([LetBinding]
bindsN,Term
bodyN,InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
isN ((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]
bindsN))
            else
              ([LetBinding]
binds1,Term
body1,InScopeSet -> [Var Term] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
isN [Var Term]
bs1)
      let bodyOccs :: VarEnv Int
bodyOccs = Fold Term (Var Term)
-> (VarEnv Int -> VarEnv Int -> VarEnv Int)
-> VarEnv Int
-> (Var Term -> VarEnv Int)
-> Term
-> VarEnv Int
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
Lens.foldMapByOf
                       Fold Term (Var Term)
freeLocalIds ((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 (Var Term -> Int -> VarEnv Int
forall b a. Var b -> a -> VarEnv a
`unitVarEnv` (Int
1 :: Int))
                       Term
body2
          ([TickInfo]
srcTicks,[TickInfo]
nmTicks) = [TickInfo] -> ([TickInfo], [TickInfo])
partitionTicks [TickInfo]
ticks
      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
      Bool
e2WorkFree <-
        case [LetBinding]
binds2 of
          [(Var Term
_,Term
e2)] -> Lens' (RewriteState NormalizeState) (VarEnv Bool)
-> VarEnv (Binding Term)
-> Term
-> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type).
(HasCallStack, MonadState s m) =>
Lens' s (VarEnv Bool) -> VarEnv (Binding Term) -> Term -> m Bool
isWorkFree forall extra. Lens' (RewriteState extra) (VarEnv Bool)
Lens' (RewriteState NormalizeState) (VarEnv Bool)
workFreeBinders VarEnv (Binding Term)
bndrs Term
e2
          [LetBinding]
_ -> Bool -> RewriteMonad NormalizeState Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (String -> Bool
forall a. HasCallStack => String -> a
error String
"flattenLet: unreachable")
      -- Distribute the name ticks of the let-expression over all the bindings
      (InScopeSet
isN1,) ([LetBinding] -> (InScopeSet, [LetBinding]))
-> ([LetBinding] -> [LetBinding])
-> [LetBinding]
-> (InScopeSet, [LetBinding])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
nmTicks)) ([LetBinding] -> (InScopeSet, [LetBinding]))
-> RewriteMonad NormalizeState [LetBinding]
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case [LetBinding]
binds2 of
        -- inline binders into the body when there's only a single binder, and
        -- only if that binder doesn't perform any work or is only used once in
        -- the body
        [(Var Term
id2,Term
e2)] | Just Int
occ <- Var Term -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Var Term
id2 VarEnv Int
bodyOccs, Bool
e2WorkFree Bool -> Bool -> Bool
|| Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 ->
          if Var Term
id2 Var Term -> Term -> Bool
`localIdOccursIn` Term
e2
             -- Except when the binder is recursive!
             then [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed ([(Var Term
id2,Term
e2),(Var Term
id1, Term
body2)])
             else let subst :: Subst
subst = Subst -> Var Term -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
isN1) Var Term
id2 Term
e2
                  in  [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed [(Var Term
id1
                               -- Only apply srcTicks to the body
                               ,Term -> [TickInfo] -> Term
mkTicks (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"flattenLetGo" Subst
subst Term
body2)
                                        [TickInfo]
srcTicks)]
        [LetBinding]
bs -> [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding]
bs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Var Term
id1
                               -- Only apply srcTicks to the body
                              ,Term -> [TickInfo] -> Term
mkTicks Term
body2 [TickInfo]
srcTicks)])
    go InScopeSet
isN LetBinding
b = (InScopeSet, [LetBinding])
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (InScopeSet
isN,[LetBinding
b])

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

-- | Worker function of 'separateArguments'.
separateLambda
  :: TyConMap
  -> TransformContext
  -> Id
  -- ^ Lambda binder
  -> Term
  -- ^ Lambda body
  -> Maybe Term
  -- ^ If lambda is split up, this function returns a Just containing the new term
separateLambda :: TyConMap -> TransformContext -> Var Term -> Term -> Maybe Term
separateLambda TyConMap
tcm ctx :: TransformContext
ctx@(TransformContext InScopeSet
is0 Context
_) Var Term
b Term
eb0 =
  case TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm (Var Term -> Kind
forall a. Var a -> Kind
varType Var Term
b) of
    Just ([Term] -> Term
dc, Projections
_, [Kind]
argTys) ->
      let
        nm :: Name Term
nm = TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx (Name Term -> Text
forall a. Name a -> Text
nameOcc (Var Term -> Name Term
forall a. Var a -> Name a
varName Var Term
b))
        bs0 :: [Var Term]
bs0 = (Kind -> Var Term) -> [Kind] -> [Var Term]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Name Term -> Var Term
`mkLocalId` Name Term
nm) [Kind]
argTys
        (InScopeSet
is1, [Var Term]
bs1) = (InScopeSet -> Var Term -> (InScopeSet, Var Term))
-> InScopeSet -> [Var Term] -> (InScopeSet, [Var Term])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL InScopeSet -> Var Term -> (InScopeSet, Var Term)
forall a. InScopeSet -> Var a -> (InScopeSet, Var a)
newBinder InScopeSet
is0 [Var Term]
bs0
        subst :: Subst
subst = Subst -> Var Term -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is1) Var Term
b ([Term] -> Term
dc ((Var Term -> Term) -> [Var Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Var Term -> Term
Var [Var Term]
bs1))
        eb1 :: Term
eb1 = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"separateArguments" Subst
subst Term
eb0
      in
        Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> [Var Term] -> Term
mkLams Term
eb1 [Var Term]
bs1)
    Maybe ([Term] -> Term, Projections, [Kind])
_ ->
      Maybe Term
forall a. Maybe a
Nothing
 where
  newBinder :: InScopeSet -> Var a -> (InScopeSet, Var a)
newBinder InScopeSet
isN0 Var a
x =
    let
      x' :: Var a
x' = InScopeSet -> Var a -> Var a
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN0 Var a
x
      isN1 :: InScopeSet
isN1 = InScopeSet -> Var a -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isN0 Var a
x'
    in
      (InScopeSet
isN1, Var a
x')
{-# SCC separateLambda #-}

-- | Split apart (global) function arguments that contain types that we
-- want to separate off, e.g. Clocks. Works on both the definition side (i.e. the
-- lambda), and the call site (i.e. the application of the global variable). e.g.
-- turns
--
-- > f :: (Clock System, Reset System) -> Signal System Int
--
-- into
--
-- > f :: Clock System -> Reset System -> Signal System Int
separateArguments :: HasCallStack => NormRewrite
separateArguments :: NormRewrite
separateArguments TransformContext
ctx e0 :: Term
e0@(Lam Var Term
b Term
eb) = 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
Lens' RewriteEnv TyConMap
tcCache
  case TyConMap -> TransformContext -> Var Term -> Term -> Maybe Term
separateLambda TyConMap
tcm TransformContext
ctx Var Term
b Term
eb of
    Just Term
e1 -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
    Maybe Term
Nothing -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e0

separateArguments (TransformContext InScopeSet
is0 Context
_) e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Var Var Term
g, [Either Term Kind]
args, [TickInfo]
ticks))
  | Var Term -> Bool
forall a. Var a -> Bool
isGlobalId Var Term
g = do
  -- We ensure that both the type of the global variable reference is updated
  -- to take into account the changed arguments, and that we apply the global
  -- function with the split apart arguments.
  let ([Either TyVar Kind]
argTys0,Kind
resTy) = Kind -> ([Either TyVar Kind], Kind)
splitFunForallTy (Var Term -> Kind
forall a. Var a -> Kind
varType Var Term
g)
  ([[(Either TyVar Kind, Either Term Kind)]]
-> [(Either TyVar Kind, Either Term Kind)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [(Either TyVar Kind, Either Term Kind)]
args1, Any -> Bool
Monoid.getAny -> Bool
hasChanged)
    <- RewriteMonad
  NormalizeState [[(Either TyVar Kind, Either Term Kind)]]
-> RewriteMonad
     NormalizeState ([[(Either TyVar Kind, Either Term Kind)]], Any)
forall w (m :: Type -> Type) a. MonadWriter w m => m a -> m (a, w)
listen (((Either TyVar Kind, Either Term Kind)
 -> RewriteMonad
      NormalizeState [(Either TyVar Kind, Either Term Kind)])
-> [(Either TyVar Kind, Either Term Kind)]
-> RewriteMonad
     NormalizeState [[(Either TyVar Kind, Either Term Kind)]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Either TyVar Kind
 -> Either Term Kind
 -> RewriteMonad
      NormalizeState [(Either TyVar Kind, Either Term Kind)])
-> (Either TyVar Kind, Either Term Kind)
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Either TyVar Kind
-> Either Term Kind
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
splitArg) ([Either TyVar Kind]
-> [Either Term Kind] -> [(Either TyVar Kind, Either Term Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Either TyVar Kind]
argTys0 [Either Term Kind]
args))
  if Bool
hasChanged then
    let ([Either TyVar Kind]
argTys1,[Either Term Kind]
args2) = [(Either TyVar Kind, Either Term Kind)]
-> ([Either TyVar Kind], [Either Term Kind])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Either TyVar Kind, Either Term Kind)]
args1
        gTy :: Kind
gTy = Kind -> [Either TyVar Kind] -> Kind
mkPolyFunTy Kind
resTy [Either TyVar Kind]
argTys1
    in  Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Term -> [Either Term Kind] -> Term
mkApps (Term -> [TickInfo] -> Term
mkTicks (Var Term -> Term
Var Var Term
g {varType :: Kind
varType = Kind
gTy}) [TickInfo]
ticks) [Either Term Kind]
args2)
  else
    Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

 where
  -- Split a single argument
  splitArg
    :: Either TyVar Type
    -- The quantifier/function argument type of the global variable
    -> Either Term Type
    -- The applied type argument or term argument
    -> NormalizeSession [(Either TyVar Type,Either Term Type)]
  splitArg :: Either TyVar Kind
-> Either Term Kind
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
splitArg Either TyVar Kind
tv arg :: Either Term Kind
arg@(Right Kind
_)    = [(Either TyVar Kind, Either Term Kind)]
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(Either TyVar Kind
tv,Either Term Kind
arg)]
  splitArg Either TyVar Kind
ty arg :: Either Term Kind
arg@(Left Term
tmArg) = 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
Lens' RewriteEnv TyConMap
tcCache
    let argTy :: Kind
argTy = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
tmArg
    case TyConMap -> Kind -> Maybe ([Term] -> Term, Projections, [Kind])
shouldSplit TyConMap
tcm Kind
argTy of
      Just ([Term] -> Term
_,Projections forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Term -> m [Term]
projections,[Kind]
_) -> do
        [Term]
tmArgs <- InScopeSet -> Term -> RewriteMonad NormalizeState [Term]
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Term -> m [Term]
projections InScopeSet
is0 Term
tmArg
        [(Either TyVar Kind, Either Term Kind)]
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
forall a extra. a -> RewriteMonad extra a
changed ((Term -> (Either TyVar Kind, Either Term Kind))
-> [Term] -> [(Either TyVar Kind, Either Term Kind)]
forall a b. (a -> b) -> [a] -> [b]
map ((Either TyVar Kind
ty,) (Either Term Kind -> (Either TyVar Kind, Either Term Kind))
-> (Term -> Either Term Kind)
-> Term
-> (Either TyVar Kind, Either Term Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Either Term Kind
forall a b. a -> Either a b
Left) [Term]
tmArgs)
      Maybe ([Term] -> Term, Projections, [Kind])
_ ->
        [(Either TyVar Kind, Either Term Kind)]
-> RewriteMonad
     NormalizeState [(Either TyVar Kind, Either Term Kind)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(Either TyVar Kind
ty,Either Term Kind
arg)]

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

-- | Remove all undefined alternatives from case expressions, replacing them
-- with the value of another defined alternative. If there is one defined
-- alternative, the entire expression is replaced with that alternative. If
-- there are no defined alternatives, the entire expression is replaced with
-- a call to 'errorX'.
--
-- e.g. It converts
--
--     case x of
--       D1 a -> f a
--       D2   -> undefined
--       D3   -> undefined
--
-- to
--
--     let subj = x
--         a    = case subj of
--                  D1 a -> field0
--      in f a
--
-- where fieldN is an internal variable referring to the nth argument of a
-- data constructor.
--
xOptimize :: HasCallStack => NormRewrite
xOptimize :: NormRewrite
xOptimize (TransformContext InScopeSet
is0 Context
_) e :: Term
e@(Case Term
subj Kind
ty [Alt]
alts) = do
  Bool
runXOpt <- Getting Bool RewriteEnv Bool -> RewriteMonad NormalizeState Bool
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting Bool RewriteEnv Bool
Lens' RewriteEnv Bool
aggressiveXOpt

  if Bool
runXOpt then do
    ([Alt], [Alt])
defPart <- (Alt -> RewriteMonad NormalizeState Bool)
-> [Alt] -> RewriteMonad NormalizeState ([Alt], [Alt])
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
List.partitionM (Term -> RewriteMonad NormalizeState Bool
isPrimError (Term -> RewriteMonad NormalizeState Bool)
-> (Alt -> Term) -> Alt -> RewriteMonad NormalizeState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Term
forall a b. (a, b) -> b
snd) [Alt]
alts

    case ([Alt], [Alt])
defPart of
      ([], [Alt]
_)    -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      ([Alt]
_, [])    -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (PrimInfo -> Term
Prim (Text -> Kind -> WorkInfo -> IsMultiPrim -> PrimInfo
PrimInfo Text
"Clash.XException.errorX" Kind
ty WorkInfo
WorkConstant IsMultiPrim
SingleResult))
      ([Alt]
_, [Alt
alt]) -> InScopeSet -> Term -> Alt -> RewriteMonad NormalizeState Term
xOptimizeSingle InScopeSet
is0 Term
subj Alt
alt
      ([Alt]
_, [Alt]
defs)  -> HasCallStack =>
InScopeSet
-> Term -> Kind -> [Alt] -> RewriteMonad NormalizeState Term
InScopeSet
-> Term -> Kind -> [Alt] -> RewriteMonad NormalizeState Term
xOptimizeMany InScopeSet
is0 Term
subj Kind
ty [Alt]
defs
  else
    Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

-- Return an expression equivalent to the alternative given. When only one
-- alternative is defined the result of this function is used to replace the
-- case expression.
--
xOptimizeSingle :: InScopeSet -> Term -> Alt -> NormalizeSession Term
xOptimizeSingle :: InScopeSet -> Term -> Alt -> RewriteMonad NormalizeState Term
xOptimizeSingle InScopeSet
is Term
subj (DataPat DataCon
dc [TyVar]
tvs [Var Term]
vars, Term
expr) = 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
Lens' RewriteEnv TyConMap
tcCache
  Var Term
subjId <- InScopeSet
-> Text -> Kind -> RewriteMonad NormalizeState (Var Term)
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m (Var Term)
mkInternalVar InScopeSet
is Text
"subj" (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
subj)

  let fieldTys :: [Kind]
fieldTys = (Var Term -> Kind) -> [Var Term] -> [Kind]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Var Term -> Kind
forall a. Var a -> Kind
varType [Var Term]
vars
  [LetBinding]
lets <- (Var Term -> Int -> RewriteMonad NormalizeState LetBinding)
-> [Var Term] -> [Int] -> RewriteMonad NormalizeState [LetBinding]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
Monad.zipWithM (InScopeSet
-> Var Term
-> DataCon
-> [TyVar]
-> [Kind]
-> Var Term
-> Int
-> RewriteMonad NormalizeState LetBinding
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet
-> Var Term
-> DataCon
-> [TyVar]
-> [Kind]
-> Var Term
-> Int
-> m LetBinding
mkFieldSelector InScopeSet
is Var Term
subjId DataCon
dc [TyVar]
tvs [Kind]
fieldTys) [Var Term]
vars [Int
0..]

  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec ((Var Term
subjId, Term
subj) LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
: [LetBinding]
lets) Term
expr)

xOptimizeSingle InScopeSet
_ Term
_ (Pat
_, Term
expr) = Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
expr

-- Given a list of alternatives which are defined, create a new case
-- expression which only ever returns a defined value.
--
xOptimizeMany
  :: HasCallStack
  => InScopeSet
  -> Term
  -> Type
  -> [Alt]
  -> NormalizeSession Term
xOptimizeMany :: InScopeSet
-> Term -> Kind -> [Alt] -> RewriteMonad NormalizeState Term
xOptimizeMany InScopeSet
is Term
subj Kind
ty defs :: [Alt]
defs@(Alt
d:[Alt]
ds)
  | [Alt] -> Bool
isAnyDefault [Alt]
defs = Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> Kind -> [Alt] -> Term
Case Term
subj Kind
ty [Alt]
defs)
  | Bool
otherwise = do
      Term
newAlt <- InScopeSet -> Term -> Alt -> RewriteMonad NormalizeState Term
xOptimizeSingle InScopeSet
is Term
subj Alt
d
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> Kind -> [Alt] -> Term
Case Term
subj Kind
ty ([Alt] -> Term) -> [Alt] -> Term
forall a b. (a -> b) -> a -> b
$ [Alt]
ds [Alt] -> [Alt] -> [Alt]
forall a. Semigroup a => a -> a -> a
<> [(Pat
DefaultPat, Term
newAlt)])
 where
  isAnyDefault :: [Alt] -> Bool
  isAnyDefault :: [Alt] -> Bool
isAnyDefault = (Alt -> Bool) -> [Alt] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any ((Pat -> Pat -> Bool
forall a. Eq a => a -> a -> Bool
== Pat
DefaultPat) (Pat -> Bool) -> (Alt -> Pat) -> Alt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> Pat
forall a b. (a, b) -> a
fst)

xOptimizeMany InScopeSet
_ Term
_ Kind
_ [] =
  String -> RewriteMonad NormalizeState Term
forall a. HasCallStack => String -> a
error (String -> RewriteMonad NormalizeState Term)
-> String -> RewriteMonad NormalizeState Term
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Report as bug: xOptimizeMany error: No defined alternatives"

mkFieldSelector
  :: MonadUnique m
  => InScopeSet
  -> Id
  -- ^ subject id
  -> DataCon
  -> [TyVar]
  -> [Type]
  -- ^ concrete types of fields
  -> Id
  -> Int
  -> m LetBinding
mkFieldSelector :: InScopeSet
-> Var Term
-> DataCon
-> [TyVar]
-> [Kind]
-> Var Term
-> Int
-> m LetBinding
mkFieldSelector InScopeSet
is0 Var Term
subj DataCon
dc [TyVar]
tvs [Kind]
fieldTys Var Term
nm Int
index = do
  [Var Term]
fields <- (Kind -> m (Var Term)) -> [Kind] -> m [Var Term]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Kind
ty -> InScopeSet -> Text -> Kind -> m (Var Term)
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m (Var Term)
mkInternalVar InScopeSet
is0 Text
"field" Kind
ty) [Kind]
fieldTys
  let alt :: Alt
alt = (DataCon -> [TyVar] -> [Var Term] -> Pat
DataPat DataCon
dc [TyVar]
tvs [Var Term]
fields, Var Term -> Term
Var (Var Term -> Term) -> Var Term -> Term
forall a b. (a -> b) -> a -> b
$ [Var Term]
fields [Var Term] -> Int -> Var Term
forall a. [a] -> Int -> a
!! Int
index)
  LetBinding -> m LetBinding
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Var Term
nm, Term -> Kind -> [Alt] -> Term
Case (Var Term -> Term
Var Var Term
subj) ([Kind]
fieldTys [Kind] -> Int -> Kind
forall a. [a] -> Int -> a
!! Int
index) [Alt
alt])

-- Check whether a term is really a black box primitive representing an error.
-- Such values are undefined and are removed in X Optimization.
--
isPrimError :: Term -> NormalizeSession Bool
isPrimError :: Term -> RewriteMonad NormalizeState Bool
isPrimError (Term -> (Term, [Either Term Kind])
collectArgs -> (Prim PrimInfo
pInfo, [Either Term Kind]
_)) = do
  Maybe GuardedCompiledPrimitive
prim <- Getting
  (Maybe GuardedCompiledPrimitive)
  (RewriteState NormalizeState)
  (Maybe GuardedCompiledPrimitive)
-> RewriteMonad NormalizeState (Maybe GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState
 -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> RewriteState NormalizeState
-> Const
     (Maybe GuardedCompiledPrimitive) (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra ((NormalizeState
  -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
 -> RewriteState NormalizeState
 -> Const
      (Maybe GuardedCompiledPrimitive) (RewriteState NormalizeState))
-> ((Maybe GuardedCompiledPrimitive
     -> Const
          (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
    -> NormalizeState
    -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> Getting
     (Maybe GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
     (Maybe GuardedCompiledPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Text GuardedCompiledPrimitive
 -> Const
      (Maybe GuardedCompiledPrimitive)
      (HashMap Text GuardedCompiledPrimitive))
-> NormalizeState
-> Const (Maybe GuardedCompiledPrimitive) NormalizeState
Lens' NormalizeState (HashMap Text GuardedCompiledPrimitive)
primitives ((HashMap Text GuardedCompiledPrimitive
  -> Const
       (Maybe GuardedCompiledPrimitive)
       (HashMap Text GuardedCompiledPrimitive))
 -> NormalizeState
 -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> ((Maybe GuardedCompiledPrimitive
     -> Const
          (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
    -> HashMap Text GuardedCompiledPrimitive
    -> Const
         (Maybe GuardedCompiledPrimitive)
         (HashMap Text GuardedCompiledPrimitive))
-> (Maybe GuardedCompiledPrimitive
    -> Const
         (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
-> NormalizeState
-> Const (Maybe GuardedCompiledPrimitive) NormalizeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text GuardedCompiledPrimitive)
-> Lens'
     (HashMap Text GuardedCompiledPrimitive)
     (Maybe (IxValue (HashMap Text GuardedCompiledPrimitive)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at (PrimInfo -> Text
primName PrimInfo
pInfo))

  case Maybe GuardedCompiledPrimitive
prim Maybe GuardedCompiledPrimitive
-> (GuardedCompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe CompiledPrimitive
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim of
    Just CompiledPrimitive
p  -> Bool -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (CompiledPrimitive -> Bool
forall a c d. Primitive a BlackBox c d -> Bool
isErr CompiledPrimitive
p)
    Maybe CompiledPrimitive
Nothing -> Bool -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
 where
  isErr :: Primitive a BlackBox c d -> Bool
isErr BlackBox{template :: forall a b c d. Primitive a b c d -> b
template=(BBTemplate [Err Maybe Int
_])} = Bool
True
  isErr Primitive a BlackBox c d
_ = Bool
False

isPrimError Term
_ = Bool -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

-- A multi result primitive assigns its results to multiple result variables
-- instead of one. Besides producing nicer HDL it works around issues with
-- synthesis tooling described in:
--
--   https://github.com/clash-lang/clash-compiler/issues/1555
--
-- This transformation rewrites primitives indicating they can assign their
-- results to multiple signals, such that netlist can easily render it.
--
-- Example:
--
-- @
-- prim :: forall a. a -> (a, a)
-- @
--
-- will be rewritten to:
--
-- @
--   \a0 -> let
--            r  = prim @t0 a0 r0 r1     -- With 'Clash.Core.Term.MultiPrim'
--            r0 = multiPrimSelect r0 r
--            r1 = multiPrimSelect r1 r
--          in
--            (x, y)
-- @
--
-- Netlist will not render any @multiPrimSelect@ primitives. Similar to
-- primitives having a /void/ return type, /r/ is not rendered either.
--
-- This transformation is currently hardcoded to recognize tuples as return
-- types, not any product type. It will error if it sees a multi result primitive
-- with a non-tuple return type.
--
setupMultiResultPrim :: HasCallStack => NormRewrite
setupMultiResultPrim :: NormRewrite
setupMultiResultPrim TransformContext
_ctx e :: Term
e@(Prim pInfo :: PrimInfo
pInfo@PrimInfo{primMultiResult :: PrimInfo -> IsMultiPrim
primMultiResult=IsMultiPrim
SingleResult}) = 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
Lens' RewriteEnv TyConMap
tcCache
  Maybe GuardedCompiledPrimitive
prim <- Getting
  (Maybe GuardedCompiledPrimitive)
  (RewriteState NormalizeState)
  (Maybe GuardedCompiledPrimitive)
-> RewriteMonad NormalizeState (Maybe GuardedCompiledPrimitive)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use ((NormalizeState
 -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> RewriteState NormalizeState
-> Const
     (Maybe GuardedCompiledPrimitive) (RewriteState NormalizeState)
forall extra extra2.
Lens (RewriteState extra) (RewriteState extra2) extra extra2
extra ((NormalizeState
  -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
 -> RewriteState NormalizeState
 -> Const
      (Maybe GuardedCompiledPrimitive) (RewriteState NormalizeState))
-> ((Maybe GuardedCompiledPrimitive
     -> Const
          (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
    -> NormalizeState
    -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> Getting
     (Maybe GuardedCompiledPrimitive)
     (RewriteState NormalizeState)
     (Maybe GuardedCompiledPrimitive)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Text GuardedCompiledPrimitive
 -> Const
      (Maybe GuardedCompiledPrimitive)
      (HashMap Text GuardedCompiledPrimitive))
-> NormalizeState
-> Const (Maybe GuardedCompiledPrimitive) NormalizeState
Lens' NormalizeState (HashMap Text GuardedCompiledPrimitive)
primitives ((HashMap Text GuardedCompiledPrimitive
  -> Const
       (Maybe GuardedCompiledPrimitive)
       (HashMap Text GuardedCompiledPrimitive))
 -> NormalizeState
 -> Const (Maybe GuardedCompiledPrimitive) NormalizeState)
-> ((Maybe GuardedCompiledPrimitive
     -> Const
          (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
    -> HashMap Text GuardedCompiledPrimitive
    -> Const
         (Maybe GuardedCompiledPrimitive)
         (HashMap Text GuardedCompiledPrimitive))
-> (Maybe GuardedCompiledPrimitive
    -> Const
         (Maybe GuardedCompiledPrimitive) (Maybe GuardedCompiledPrimitive))
-> NormalizeState
-> Const (Maybe GuardedCompiledPrimitive) NormalizeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text GuardedCompiledPrimitive)
-> Lens'
     (HashMap Text GuardedCompiledPrimitive)
     (Maybe (IxValue (HashMap Text GuardedCompiledPrimitive)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at (PrimInfo -> Text
primName PrimInfo
pInfo))

  case Maybe GuardedCompiledPrimitive
prim Maybe GuardedCompiledPrimitive
-> (GuardedCompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe CompiledPrimitive
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= GuardedCompiledPrimitive -> Maybe CompiledPrimitive
forall a. PrimitiveGuard a -> Maybe a
extractPrim of
    Just (BlackBoxHaskell{multiResult :: forall a b c d. Primitive a b c d -> Bool
multiResult=Bool
True}) ->
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (HasCallStack => TyConMap -> PrimInfo -> Term
TyConMap -> PrimInfo -> Term
setupMultiResultPrim' TyConMap
tcm PrimInfo
pInfo)
    Just (BlackBox{multiResult :: forall a b c d. Primitive a b c d -> Bool
multiResult=Bool
True}) ->
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (HasCallStack => TyConMap -> PrimInfo -> Term
TyConMap -> PrimInfo -> Term
setupMultiResultPrim' TyConMap
tcm PrimInfo
pInfo)
    Maybe CompiledPrimitive
_ ->
      Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

setupMultiResultPrim' :: HasCallStack => TyConMap -> PrimInfo -> Term
setupMultiResultPrim' :: TyConMap -> PrimInfo -> Term
setupMultiResultPrim' TyConMap
tcm primInfo :: PrimInfo
primInfo@PrimInfo{Kind
primType :: Kind
primType :: PrimInfo -> Kind
primType} =
  Term -> [Either (Var Term) TyVar] -> Term
mkAbstraction Term
letTerm ((TyVar -> Either (Var Term) TyVar)
-> [TyVar] -> [Either (Var Term) TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Either (Var Term) TyVar
forall a b. b -> Either a b
Right [TyVar]
typeVars [Either (Var Term) TyVar]
-> [Either (Var Term) TyVar] -> [Either (Var Term) TyVar]
forall a. Semigroup a => a -> a -> a
<> (Var Term -> Either (Var Term) TyVar)
-> [Var Term] -> [Either (Var Term) TyVar]
forall a b. (a -> b) -> [a] -> [b]
map Var Term -> Either (Var Term) TyVar
forall a b. a -> Either a b
Left [Var Term]
argIds)
 where
  typeVars :: [TyVar]
typeVars = [Either TyVar Kind] -> [TyVar]
forall a b. [Either a b] -> [a]
Either.lefts [Either TyVar Kind]
pArgs

  internalNm :: Text -> Int -> Name a
internalNm Text
prefix Int
n = Text -> Int -> Name a
forall a. Text -> Int -> Name a
mkUnsafeInternalName (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
n) Int
n
  internalId :: Text -> Kind -> Int -> Var Term
internalId Text
prefix Kind
typ Int
n = Kind -> Name Term -> Var Term
mkLocalId Kind
typ (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
internalNm Text
prefix Int
n)

  nTermArgs :: Int
nTermArgs = [Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([Either TyVar Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either TyVar Kind]
pArgs)
  argIds :: [Var Term]
argIds = (Kind -> Int -> Var Term) -> [Kind] -> [Int] -> [Var Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text -> Kind -> Int -> Var Term
internalId Text
"a") ([Either TyVar Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either TyVar Kind]
pArgs) [Int
1..Int
nTermArgs]
  resIds :: [Var Term]
resIds = (Kind -> Int -> Var Term) -> [Kind] -> [Int] -> [Var Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text -> Kind -> Int -> Var Term
internalId Text
"r") [Kind]
resTypes [Int
nTermArgsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
nTermArgsInt -> Int -> Int
forall a. Num a => a -> a -> a
+[Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Kind]
resTypes]
  resId :: Var Term
resId = Kind -> Name Term -> Var Term
mkLocalId Kind
pResTy (Text -> Int -> Name Term
forall a. Text -> Int -> Name a
mkUnsafeInternalName Text
"r" (Int
nTermArgsInt -> Int -> Int
forall a. Num a => a -> a -> a
+[Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Kind]
resTypesInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

  ([Either TyVar Kind]
pArgs, Kind
pResTy) = Kind -> ([Either TyVar Kind], Kind)
splitFunForallTy Kind
primType
  MultiPrimInfo{mpi_resultDc :: MultiPrimInfo -> DataCon
mpi_resultDc=DataCon
tupTc, mpi_resultTypes :: MultiPrimInfo -> [Kind]
mpi_resultTypes=[Kind]
resTypes} =
    HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo
TyConMap -> PrimInfo -> MultiPrimInfo
multiPrimInfo' TyConMap
tcm PrimInfo
primInfo

  multiPrimSelect :: Var Term -> Kind -> LetBinding
multiPrimSelect Var Term
r Kind
t = (Var Term
r, Term -> [Term] -> Term
mkTmApps (PrimInfo -> Term
Prim (Kind -> PrimInfo
multiPrimSelectInfo Kind
t)) [Var Term -> Term
Var Var Term
r, Var Term -> Term
Var Var Term
resId])
  multiPrimSelectBinds :: [LetBinding]
multiPrimSelectBinds = (Var Term -> Kind -> LetBinding)
-> [Var Term] -> [Kind] -> [LetBinding]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Var Term -> Kind -> LetBinding
multiPrimSelect  [Var Term]
resIds [Kind]
resTypes
  multiPrimTermArgs :: [Either Term b]
multiPrimTermArgs = (Var Term -> Either Term b) -> [Var Term] -> [Either Term b]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term b
forall a b. a -> Either a b
Left (Term -> Either Term b)
-> (Var Term -> Term) -> Var Term -> Either Term b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var Term -> Term
Var) ([Var Term]
argIds [Var Term] -> [Var Term] -> [Var Term]
forall a. Semigroup a => a -> a -> a
<> [Var Term]
resIds)
  multiPrimTypeArgs :: [Either a Kind]
multiPrimTypeArgs = (TyVar -> Either a Kind) -> [TyVar] -> [Either a Kind]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Either a Kind
forall a b. b -> Either a b
Right (Kind -> Either a Kind)
-> (TyVar -> Kind) -> TyVar -> Either a Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Kind
VarTy) [TyVar]
typeVars
  multiPrimBind :: Term
multiPrimBind =
    Term -> [Either Term Kind] -> Term
mkApps
      (PrimInfo -> Term
Prim PrimInfo
primInfo{primMultiResult :: IsMultiPrim
primMultiResult=IsMultiPrim
MultiResult})
      ([Either Term Kind]
forall a. [Either a Kind]
multiPrimTypeArgs [Either Term Kind] -> [Either Term Kind] -> [Either Term Kind]
forall a. Semigroup a => a -> a -> a
<> [Either Term Kind]
forall b. [Either Term b]
multiPrimTermArgs)

  multiPrimSelectInfo :: Kind -> PrimInfo
multiPrimSelectInfo Kind
t = PrimInfo :: Text -> Kind -> WorkInfo -> IsMultiPrim -> PrimInfo
PrimInfo
    { primName :: Text
primName = Text
"c$multiPrimSelect"
    , primType :: Kind
primType = Kind -> [Either TyVar Kind] -> Kind
mkPolyFunTy Kind
pResTy [Kind -> Either TyVar Kind
forall a b. b -> Either a b
Right Kind
pResTy, Kind -> Either TyVar Kind
forall a b. b -> Either a b
Right Kind
t]
    , primWorkInfo :: WorkInfo
primWorkInfo = WorkInfo
WorkAlways
    , primMultiResult :: IsMultiPrim
primMultiResult = IsMultiPrim
SingleResult }

  letTerm :: Term
letTerm =
    [LetBinding] -> Term -> Term
Letrec
      ((Var Term
resId,Term
multiPrimBind)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
multiPrimSelectBinds)
      (Term -> [Term] -> Term
mkTmApps (Term -> [Kind] -> Term
mkTyApps (DataCon -> Term
Data DataCon
tupTc) [Kind]
resTypes) ((Var Term -> Term) -> [Var Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Var Term -> Term
Var [Var Term]
resIds))

-- | 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 (m :: Type -> Type) p a b.
Monad m =>
p -> (Var a, b) -> m Bool
test
  where
    test :: p -> (Var a, b) -> m Bool
test p
_ (Var a
i,b
_) = case Kind -> TypeView
tyView (Var a -> Kind
forall a. Var a -> Kind
varType Var a
i) of
      TyConApp TyConName
tc [Kind]
_ -> 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
== Text
"Clash.Explicit.SimIO.SimIO"
      TypeView
_ -> Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
{-# SCC inlineSimIO #-}