{-|
  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 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
  , flattenLet
  , splitCastWork
  , inlineCast
  , caseCast
  , letCast
  , eliminateCastCast
  , argCastSpec
  , etaExpandSyn
  , appPropFast
  , separateArguments
  , separateLambda
  , xOptimize
  )
where

import           Control.Exception           (throw)
import           Control.Lens                (_2)
import qualified Control.Lens                as Lens
import qualified Control.Monad               as Monad
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 qualified Data.Either                 as Either
import qualified Data.HashMap.Lazy           as HashMap
import qualified Data.HashMap.Strict         as HashMapS
import qualified Data.List                   as List
import           Data.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
import qualified Data.Vector.Primitive       as PV
import           Debug.Trace
import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..))

import           BasicTypes                  (InlineSpec (..))

import           Clash.Annotations.Primitive (extractPrim)
import           Clash.Core.DataCon          (DataCon (..))
import           Clash.Core.Name
  (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           (showPpr)
import           Clash.Core.Subst
  (Subst, substTm, mkSubst, extendIdSubst, extendIdSubstList, extendTvSubst,
   extendTvSubstList, freshenTm, substTyInVar, deShadowTerm, deShadowAlt,
   deshadowLetExpr)
import           Clash.Core.Term
  ( LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..)
  , TickInfo(..) , WorkInfo(WorkConstant), Alt, TickInfo
  , isLambdaBodyCtx, isTickCtx, collectArgs
  , collectArgsTicks, collectTicks , partitionTicks
  )
import           Clash.Core.Type             (Type (..), TypeView (..), applyFunTy,
                                              isPolyFunCoreTy, isClassTy,
                                              normalizeType, splitFunForallTy,
                                              splitFunTy,
                                              tyView, mkPolyFunTy, coreView,
                                              LitTy (..), coreView1)
import           Clash.Core.TyCon            (TyConMap, tyConDataCons)
import           Clash.Core.Util
  (isCon, isFun, isLet, isPolyFun, isPrim,
   isSignalType, isVar, mkApps, mkLams, mkVec, piResultTy, termSize, termType,
   tyNatSize, patVars, isAbsurdAlt, altEqs, substInExistentialsList,
   solveNonAbsurds, patIds, isLocalVar, undefinedTm, stripTicks, mkTicks,
   shouldSplit, inverseTopSortLetBindings)
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, eltsVarSet)
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                (Unique, lookupUniqMap)
import           Clash.Util

inlineOrLiftNonRep :: HasCallStack => NormRewrite
inlineOrLiftNonRep :: NormRewrite
inlineOrLiftNonRep ctx :: TransformContext
ctx eLet :: Term
eLet@(Letrec _ body :: 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}, _)
      = 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 _ = 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 e :: Term
e (id_ :: Id
id_, e' :: 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)
          Id -> Term -> Bool
isJoinPointIn Id
id_ Term
e Bool -> Bool -> Bool
&& Bool -> Bool
not (Term -> Bool
isVoidWrapper Term
e')
          -- 3. binders that are used more than once in the body, because
          --    it makes CSE a whole lot more difficult.
          --
          -- XXX: Check whether we can extend this to the binders as well
        , Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>1) (Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
bodyFreeOccs)
        ]

inlineOrLiftNonRep _ e :: 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 ctx :: TransformContext
ctx e :: Term
e@(TyApp e1 :: Term
e1 ty :: Kind
ty)
  | (Var {},  args :: [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
  , (_, []) <- [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 _ e :: 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 ctx :: TransformContext
ctx e :: Term
e@(App e1 :: Term
e1 e2 :: Term
e2)
  | (Var {}, args :: [Either Term Kind]
args) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e1
  , (_, [])     <- [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 app :: Term
app
      | (Var f :: Id
f,fArgs :: [Either Term Kind]
fArgs,ticks :: [TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
app
      = do
        Maybe Binding
fTmM <- Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f (VarEnv Binding -> Maybe Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
-> RewriteMonad NormalizeState (Maybe Binding)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
bindings
        case Maybe Binding
fTmM of
          Just b :: Binding
b
            | Name Term -> NameSort
forall a. Name a -> NameSort
nameSort (Id -> Name Term
forall a. Var a -> Name a
varName (Binding -> Id
bindingId Binding
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
bindingTerm Binding
b) [TickInfo]
ticks) [Either Term Kind]
fArgs))
          _ -> 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 _ e :: 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 is0 :: InScopeSet
is0 _) (Case (Term -> (Term, [TickInfo])
collectTicks -> (Letrec xes :: [LetBinding]
xes e :: Term
e,ticks :: [TickInfo]
ticks)) ty :: Kind
ty alts :: [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 (xes1 :: [LetBinding]
xes1,e1 :: 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 _ e :: 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 _ case0 :: Term
case0@(Case scrut :: Term
scrut altsTy :: Kind
altsTy alts0 :: [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 (altsAbsurd :: [Alt]
altsAbsurd, altsOther :: [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
    _  -> 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 _ e :: 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 is0 :: InScopeSet
is0 _) (Case scrut :: Term
scrut altsTy :: Kind
altsTy alts0 :: [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 is2 :: InScopeSet
is2 tcm :: TyConMap
tcm alt :: Alt
alt@(DataPat dc :: DataCon
dc exts0 :: [TyVar]
exts0 xs0 :: [Id]
xs0, term0 :: Term
term0) =
      case TyConMap -> [(Kind, Kind)] -> [(TyVar, Kind)]
solveNonAbsurds TyConMap
tcm (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:
        sols :: [(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] -> [Id] -> Pat
DataPat DataCon
dc [TyVar]
exts1 [Id]
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 :: [Id]
xs1   = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Id -> Id
forall a. HasCallStack => Subst -> Var a -> Var a
substTyInVar (Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is3) [(TyVar, Kind)]
sols)) [Id]
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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is3 [Id]
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 "Replacing tyVar due to solved eq" Subst
subst Term
term0

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

elemExistentials _ e :: 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 is0 :: InScopeSet
is0 _) e :: Term
e@(Case (Term -> Term
stripTicks -> Case scrut :: Term
scrut alts1Ty :: Kind
alts1Ty alts1 :: [Alt]
alts1) alts2Ty :: Kind
alts2Ty alts2 :: [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 (\altE :: 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 _ e :: 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
inlineNonRep :: HasCallStack => NormRewrite
inlineNonRep :: NormRewrite
inlineNonRep _ e :: Term
e@(Case scrut :: Term
scrut altsTy :: Kind
altsTy alts :: [Alt]
alts)
  | (Var f :: Id
f, args :: [Either Term Kind]
args,ticks :: [TickInfo]
ticks) <- Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
scrut
  , Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
f
  = do
    (cf :: Id
cf,_)    <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra. Lens' (RewriteState extra) (Id, SrcSpan)
curFun
    Maybe Int
isInlined <- State NormalizeState (Maybe Int)
-> RewriteMonad NormalizeState (Maybe Int)
forall extra a. State extra a -> RewriteMonad extra a
zoomExtra (Id -> Id -> State NormalizeState (Maybe Int)
alreadyInlined Id
f Id
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
        noException :: Bool
noException = Bool -> Bool
not (TyConMap -> Kind -> Bool
exception TyConMap
tcm Kind
scrutTy)
    if Bool
noException Bool -> Bool -> Bool
&& (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Maybe.fromMaybe 0 Maybe Int
isInlined) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit
      then
        String
-> RewriteMonad NormalizeState Term
-> RewriteMonad NormalizeState Term
forall a. String -> a -> a
trace ([String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "InlineNonRep: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name Term -> String
forall p. PrettyPrec p => p -> String
showPpr (Id -> Name Term
forall a. Var a -> Name a
varName Id
f)
                      ," 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]
++ " times in:"
                      , Name Term -> String
forall p. PrettyPrec p => p -> String
showPpr (Id -> Name Term
forall a. Var a -> Name a
varName Id
cf)
                      , "\nType of the subject is: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall p. PrettyPrec p => p -> String
showPpr Kind
scrutTy
                      , "\nFunction " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name Term -> String
forall p. PrettyPrec p => p -> String
showPpr (Id -> Name Term
forall a. Var a -> Name a
varName Id
cf)
                      , " will not reach a normal form, and compilation"
                      , " might fail."
                      , "\nRun with '-fclash-inline-limit=N' to increase"
                      , " the inlining limit to N."
                      ])
              (Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e)
      else do
        Maybe Binding
bodyMaybe   <- Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f (VarEnv Binding -> Maybe Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
-> RewriteMonad NormalizeState (Maybe Binding)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
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
bodyMaybe) of
          (True,Just b :: Binding
b) -> do
            Bool
-> RewriteMonad NormalizeState () -> RewriteMonad NormalizeState ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
Monad.when Bool
noException (State NormalizeState () -> RewriteMonad NormalizeState ()
forall extra a. State extra a -> RewriteMonad extra a
zoomExtra (Id -> Id -> State NormalizeState ()
addNewInline Id
f Id
cf))

            let scrutBody0 :: Term
scrutBody0 = Term -> [TickInfo] -> Term
mkTicks (Binding -> Term
bindingTerm Binding
b) (Id -> TickInfo
mkInlineTick Id
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

          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
  where
    exception :: TyConMap -> Kind -> Bool
exception = TyConMap -> Kind -> Bool
isClassTy

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

-- | 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 is0 :: InScopeSet
is0 _) e :: Term
e@(Case subj :: Term
subj ty :: Kind
ty alts :: [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 dc :: DataCon
dc, args :: [Either Term Kind]
args, ticks :: [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 _ tvs :: [TyVar]
tvs xs :: [Id]
xs, altE :: Term
altE) -> do
      let is1 :: InScopeSet
is1 = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList (InScopeSet -> [TyVar] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [TyVar]
tvs) [Id]
xs
      let fvs :: UniqSet (Var Any)
fvs = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
altE
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs ([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
          altE1 :: Term
altE1 = case [LetBinding]
binds1 of
            [] -> Term
altE
            _  ->
              -- See Note [CaseCon deshadow]
              let
                ((is3 :: InScopeSet
is3,substIds :: [LetBinding]
substIds),binds2 :: [Maybe LetBinding]
binds2) = ((InScopeSet, [LetBinding])
 -> LetBinding -> ((InScopeSet, [LetBinding]), Maybe LetBinding))
-> (InScopeSet, [LetBinding])
-> [LetBinding]
-> ((InScopeSet, [LetBinding]), [Maybe LetBinding])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL (InScopeSet, [LetBinding])
-> LetBinding -> ((InScopeSet, [LetBinding]), Maybe LetBinding)
newBinder (InScopeSet
is1,[]) [LetBinding]
binds1
                subst :: Subst
subst = Subst -> [LetBinding] -> Subst
extendIdSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is3) [LetBinding]
substIds
                body :: Term
body  = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "caseCon0" Subst
subst Term
altE
              in
                case [Maybe LetBinding] -> [LetBinding]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe LetBinding]
binds2 of
                  []     -> Term
body
                  binds3 :: [LetBinding]
binds3 -> [LetBinding] -> Term -> Term
Letrec [LetBinding]
binds3 Term
body
      -- Use the original inScopeSet 'is0' here, not the extended inScopeSet
      -- 'is1', otherwise we'd make the "caseCon1" substitution substitute
      -- free variables that were shadowed by the pattern!
      let subst :: Subst
subst = Subst -> [(TyVar, Kind)] -> Subst
extendTvSubstList (InScopeSet -> Subst
mkSubst InScopeSet
is0)
                ([(TyVar, Kind)] -> Subst) -> [(TyVar, Kind)] -> Subst
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Kind] -> [(TyVar, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [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))
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "caseCon1" Subst
subst Term
altE1)
    _ -> 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.
           ((DefaultPat,altE :: Term
altE):_) -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
           _ -> 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 dcPat :: DataCon
dcPat _ _) = DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Int
dcTag DataCon
dcPat
      equalCon _                   = 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 -> ((InScopeSet, [LetBinding]), Maybe LetBinding)
newBinder (isN0 :: InScopeSet
isN0,substN :: [LetBinding]
substN) (x :: Id
x,arg :: Term
arg)
        | Term -> Bool
isWorkFree Term
arg
        = ((InScopeSet
isN0,(Id
x,Term
arg)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
substN),Maybe LetBinding
forall a. Maybe a
Nothing)
        | Bool
otherwise
        = let x' :: Id
x'   = InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN0 Id
x
              isN1 :: InScopeSet
isN1 = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isN0 Id
x'
          in  ((InScopeSet
isN1,(Id
x,Id -> Term
Var Id
x')LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
substN),LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just (Id
x',Term
arg))


  -- The subject is a literal
  (Literal l :: Literal
l,_,_) -> 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 _,altE :: Term
altE) -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
    _ -> Term -> Literal -> [Alt] -> RewriteMonad NormalizeState Term
matchLiteralContructor Term
e Literal
l [Alt]
alts
    where
      equalLit :: Pat -> Bool
equalLit (LitPat l' :: Literal
l')     = Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l'
      equalLit _               = Bool
False


  -- The subject is an applied primitive
  (Prim _,_,_) ->
    -- 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
$ \ctx1 :: TransformContext
ctx1 subj1 :: Term
subj1 -> case Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks Term
subj1 of
      -- WHNF of subject is a literal, try `caseCon` with that
      (Literal l :: Literal
l,_,_) -> 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 _,_,_) -> 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 pInfo :: PrimInfo
pInfo,_:msgOrCallStack :: Either Term Kind
msgOrCallStack:_,ticks :: [TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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 pInfo :: PrimInfo
pInfo,repTy :: Either Term Kind
repTy:_:msgOrCallStack :: Either Term Kind
msgOrCallStack:_,ticks :: [TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` ["Control.Exception.Base.patError"
#if !MIN_VERSION_ghc(8,2,2)
                                ,"Control.Exception.Base.absentError"
#endif
                                ,"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 pInfo :: PrimInfo
pInfo,[_],ticks :: [TickInfo]
ticks)
        | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ "Clash.Transformations.undefined"
                                , "Clash.GHC.Evaluator.undefined"
                                , "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
      -- 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.
      _ -> 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 hty :: HWType
hty)) _areVoids :: [[(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 0, Int -> HWType
Unsigned 0, Int -> HWType
Signed 0, Integer -> HWType
Index 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 0)) Kind
ty [Alt]
alts)
          _ -> 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)
                      ("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]
++
                       "\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 v :: Id
v, [], _) | Kind -> Bool
isNum0 (Id -> Kind
forall a. Var a -> Kind
varType Id
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 0)) Kind
ty [Alt]
alts)
   where
    isNum0 :: Kind -> Bool
isNum0 (Kind -> TypeView
tyView -> TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
tcNm) [arg :: Kind
arg])
      | Text
tcNm Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem`
        ["Clash.Sized.Internal.BitVector.BitVector"
        ,"Clash.Sized.Internal.Unsigned.Unsigned"
        ,"Clash.Sized.Internal.Signed.Signed"
        ]
      = Integer -> Kind -> Bool
isLitX 0 Kind
arg
      | Text
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==
        "Clash.Sized.Internal.Index.Index"
      = Integer -> Kind -> Bool
isLitX 1 Kind
arg
    isNum0 (TyConMap -> Kind -> Maybe Kind
coreView1 TyConMap
tcm -> Just t :: Kind
t) = Kind -> Bool
isNum0 Kind
t
    isNum0 _ = Bool
False

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

  -- Otherwise check whether the entire case-expression has a single
  -- alternative, and pick that one.
  _ -> Term -> RewriteMonad NormalizeState Term
forall extra. Term -> RewriteMonad extra Term
caseOneAlt Term
e

caseCon _ e :: 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 c :: Term
c (IntegerLiteral l :: Integer
l) alts :: [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 [(DefaultPat,e :: Term
e)] = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
  go ((DataPat dc :: DataCon
dc [] xs :: [Id]
xs,e :: Term
e):alts' :: [Alt]
alts')
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= ((-2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)) Bool -> Bool -> Bool
&&  Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)
    = let fvs :: UniqSet (Var Any)
fvs       = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs [Literal -> Term
Literal (Integer -> Literal
IntLiteral Integer
l)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 _  -> [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
== 2
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int)
    = let !(Jp# !(BN# ba :: ByteArray#
ba)) = Integer
l
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          bv :: Vector a
bv        = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba') ByteArray
ba'
          fvs :: UniqSet (Var Any)
fvs       = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs [Literal -> Term
Literal (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 _  -> [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
== 3
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< ((-2)Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(63::Int))
    = let !(Jn# !(BN# ba :: ByteArray#
ba)) = Integer
l
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          bv :: Vector a
bv        = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba') ByteArray
ba'
          fvs :: UniqSet (Var Any)
fvs       = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs [Literal -> Term
Literal (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 _  -> [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 l' :: Literal
l', e :: Term
e):alts' :: [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 _ = 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 c :: Term
c (NaturalLiteral l :: Integer
l) alts :: [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 [(DefaultPat,e :: Term
e)] = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
  go ((DataPat dc :: DataCon
dc [] xs :: [Id]
xs,e :: Term
e):alts' :: [Alt]
alts')
    | DataCon -> Int
dcTag DataCon
dc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(64::Int)
    = let fvs :: UniqSet (Var Any)
fvs       = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs [Literal -> Term
Literal (Integer -> Literal
WordLiteral Integer
l)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 _  -> [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
== 2
    , Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(64::Int)
    = let !(Jp# !(BN# ba :: ByteArray#
ba)) = Integer
l
          ba' :: ByteArray
ba'       = ByteArray# -> ByteArray
BA.ByteArray ByteArray#
ba
          bv :: Vector a
bv        = Int -> Int -> ByteArray -> Vector a
forall a. Int -> Int -> ByteArray -> Vector a
PV.Vector 0 (ByteArray -> Int
BA.sizeofByteArray ByteArray
ba') ByteArray
ba'
          fvs :: UniqSet (Var Any)
fvs       = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e
          (binds :: [LetBinding]
binds,_) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
fvs) (Id -> Bool) -> (LetBinding -> Id) -> LetBinding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Id
forall a b. (a, b) -> a
fst)
                    ([LetBinding] -> ([LetBinding], [LetBinding]))
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a b. (a -> b) -> a -> b
$ [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
xs [Literal -> Term
Literal (Vector Word8 -> Literal
ByteArrayLiteral Vector Word8
forall a. Vector a
bv)]
          e' :: Term
e' = case [LetBinding]
binds of
                 [] -> Term
e
                 _  -> [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 l' :: Literal
l', e :: Term
e):alts' :: [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 _ = 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 _ _ ((DefaultPat,e :: Term
e):_) = Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e
matchLiteralContructor c :: Term
c _ _ =
  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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 _ _ [(pat :: Pat
pat,altE :: Term
altE)]) = case Pat
pat of
  DefaultPat -> Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
  LitPat _ -> Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
altE
  DataPat _ tvs :: [TyVar]
tvs xs :: [Id]
xs
    | ([TyVar] -> [Var Any]
forall a b. Coercible a b => a -> b
coerce [TyVar]
tvs [Var Any] -> [Var Any] -> [Var Any]
forall a. [a] -> [a] -> [a]
++ [Id] -> [Var Any]
forall a b. Coercible a b => a -> b
coerce [Id]
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 _ _ alts :: [Alt]
alts@((_,alt :: Term
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)
  = Term -> RewriteMonad extra Term
forall a extra. a -> RewriteMonad extra a
changed Term
alt

caseOneAlt e :: 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 is0 :: InScopeSet
is0 _) e :: Term
e@(App appConPrim :: Term
appConPrim arg :: Term
arg)
  | (conPrim :: Term
conPrim, _) <- 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
      (True,Letrec binds :: [LetBinding]
binds body :: Term
body) ->
        -- This is a situation similar to Note [CaseLet deshadow]
        let (binds1 :: [LetBinding]
binds1,body1 :: 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))
      (True,Case {})  -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      (True,Lam {})   -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      (True,TyLam {}) -> NormRewrite
specializeNorm TransformContext
ctx Term
e
      _               -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

nonRepANF _ e :: 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 is0 :: InScopeSet
is0 ctx :: Context
ctx) e :: Term
e
  | (CoreContext -> Bool) -> Context -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\c :: 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
            Id
argId <- InScopeSet
-> TyConMap -> Name Any -> Term -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is0 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName "result" 0) Term
e
            Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec [(Id
argId, Term
e)] (Id -> Term
Var Id
argId))
 where
  isTick :: Term -> Bool
isTick Tick{} = Bool
True
  isTick _ = Bool
False

topLet (TransformContext is0 :: InScopeSet
is0 ctx :: Context
ctx) e :: Term
e@(Letrec binds :: [LetBinding]
binds body :: Term
body)
  | (CoreContext -> Bool) -> Context -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\c :: 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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
binds)
        Id
argId <- InScopeSet
-> TyConMap -> Name Any -> Term -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is2 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName "result" 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]
++ [(Id
argId,Term
body)]) (Id -> Term
Var Id
argId))

topLet _ e :: 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 _ e :: Term
e@(Letrec binds :: [LetBinding]
binds body :: Term
body) = do
  let bodyFVs :: UniqSet (Var Any)
bodyFVs = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
body
      used :: VarEnv LetBinding
used    = (VarEnv LetBinding -> Var Any -> VarEnv LetBinding)
-> VarEnv LetBinding -> [Var Any] -> VarEnv LetBinding
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' VarEnv LetBinding -> Var Any -> VarEnv LetBinding
collectUsed VarEnv LetBinding
forall a. VarEnv a
emptyVarEnv (UniqSet (Var Any) -> [Var Any]
eltsVarSet UniqSet (Var Any)
bodyFVs)
  case VarEnv LetBinding -> [LetBinding]
forall a. VarEnv a -> [a]
eltsVarEnv VarEnv LetBinding
used of
    [] -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
body
    qqL :: [LetBinding]
qqL | [LetBinding] -> [LetBinding] -> Bool
forall a b. [a] -> [b] -> Bool
neLength [LetBinding]
qqL [LetBinding]
binds
        -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding] -> Term -> Term
Letrec [LetBinding]
qqL Term
body)
        | Bool
otherwise
        -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
 where
  bindsEnv :: VarEnv LetBinding
bindsEnv = [(Id, LetBinding)] -> VarEnv LetBinding
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv ((LetBinding -> (Id, LetBinding))
-> [LetBinding] -> [(Id, LetBinding)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: Id
x,e0 :: Term
e0) -> (Id
x,(Id
x,Term
e0))) [LetBinding]
binds)

  collectUsed :: VarEnv LetBinding -> Var Any -> VarEnv LetBinding
collectUsed env :: VarEnv LetBinding
env v :: Var Any
v =
    if Var Any
v Var Any -> VarEnv LetBinding -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` VarEnv LetBinding
env then
      VarEnv LetBinding
env
    else
      case Var Any -> VarEnv LetBinding -> Maybe LetBinding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Var Any
v VarEnv LetBinding
bindsEnv of
        Just (x :: Id
x,e0 :: Term
e0) ->
          let eFVs :: UniqSet (Var Any)
eFVs = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
e0
          in  (VarEnv LetBinding -> Var Any -> VarEnv LetBinding)
-> VarEnv LetBinding -> [Var Any] -> VarEnv LetBinding
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' VarEnv LetBinding -> Var Any -> VarEnv LetBinding
collectUsed
                          (Id -> LetBinding -> VarEnv LetBinding -> VarEnv LetBinding
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
x (Id
x,Term
e0) VarEnv LetBinding
env)
                          (UniqSet (Var Any) -> [Var Any]
eltsVarSet UniqSet (Var Any)
eFVs)
        Nothing -> VarEnv LetBinding
env

deadCode _ e :: 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 _ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (p :: Term
p@(Prim pInfo :: PrimInfo
pInfo),args :: [Either Term Kind]
args,ticks :: [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 used :: [Int]
used -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
used
            IgnoredArguments ignored :: [Int]
ignored -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just ([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
- 1] [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int]
ignored)
        Just (BlackBox pNm :: Text
pNm _ _ _ _ _ _ _ _ inc :: [((Text, Text), BlackBox)]
inc r :: Maybe BlackBox
r ri :: Maybe BlackBox
ri templ :: 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 -> [0,1,2]
             | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"
                                     , "Clash.Sized.Vector.splitAt"
                                     ] -> [0,1]
             | Bool
otherwise -> [[Int]] -> [Int]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ [Int] -> (BlackBox -> [Int]) -> Maybe BlackBox -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] BlackBox -> [Int]
getUsedArguments Maybe BlackBox
r
                                   , [Int] -> (BlackBox -> [Int]) -> Maybe BlackBox -> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] BlackBox -> [Int]
getUsedArguments Maybe 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 [Int]
forall a. Maybe a
Nothing

  case Maybe [Int]
usedArgs0 of
    Nothing ->
      Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    Just usedArgs1 :: [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
      (args1 :: [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 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 _ _ _ [] = [Either Term b] -> RewriteMonad extra [Either Term b]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
    go tcm :: TyConMap
tcm !Int
n used :: t Int
used (Right ty :: b
ty:args' :: [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 tcm :: TyConMap
tcm !Int
n used :: t Int
used (Left tm :: Term
tm : args' :: [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
+1) t Int
used [Either Term b]
args'
      case Term
tm of
        TyApp (Prim p0 :: PrimInfo
p0) _
          | PrimInfo -> Text
primName PrimInfo
p0 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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'')
        _ -> 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 _ e :: Term
e@(Case _ _ [(DataPat _ [] xs :: [Id]
xs,altExpr :: Term
altExpr)]) =
  if [Id]
xs [Id] -> 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 _ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Data dc :: DataCon
dc, [_,Right aTy :: Kind
aTy,Right nTy :: Kind
nTy,_,Left a :: Term
a,Left nil :: Term
nil],ticks :: [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
== "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 0
        | (con :: Term
con, _) <- 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 vecTcNm :: TyConName
vecTcNm _) = Kind -> TypeView
tyView Kind
eTy
               (Just vecTc :: TyCon
vecTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
vecTcNm TyConMap
tcm
               [nilCon :: DataCon
nilCon,consCon :: 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 1 [Term
a]) [TickInfo]
ticks
           in  Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
v
      _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

removeUnusedExpr _ e :: 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 p. p -> LetBinding -> RewriteMonad NormalizeState Bool
test
  where
    test :: p -> LetBinding -> RewriteMonad NormalizeState Bool
test _ (i :: Id
i,Term -> Term
stripTicks -> Term
e) = case Term -> Bool
isLocalVar Term
e of
      -- Don't inline `let x = x in x`, it throws  us in an infinite loop
      True -> Bool -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
i Id -> Term -> Bool
`localIdDoesNotOccurIn` Term
e)
      _    -> Term -> RewriteMonad NormalizeState Bool
forall extra. Term -> RewriteMonad extra Bool
isWorkFreeIsh Term
e RewriteMonad NormalizeState Bool
-> (Bool -> RewriteMonad NormalizeState Bool)
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        True -> 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
inlineConstantLimit) RewriteMonad NormalizeState Word
-> (Word -> RewriteMonad NormalizeState Bool)
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          0 -> Bool -> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
          n :: Word
n -> Bool -> RewriteMonad NormalizeState 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 -> RewriteMonad NormalizeState 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 _ (Cast (Term -> Term
stripTicks -> Case subj :: Term
subj ty :: Kind
ty alts :: [Alt]
alts) ty1 :: Kind
ty1 ty2 :: Kind
ty2) = do
  let alts' :: [Alt]
alts' = (Alt -> Alt) -> [Alt] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map (\(p :: Pat
p,e :: 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 _ e :: 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 _ (Cast (Term -> Term
stripTicks -> Letrec binds :: [LetBinding]
binds body :: Term
body) ty1 :: Kind
ty1 ty2 :: 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 _ e :: 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 ctx :: TransformContext
ctx e :: Term
e@(App _ (Term -> Term
stripTicks -> Cast e' :: Term
e' _ _)) =
  if Term -> Bool
isWorkFree Term
e' then
    RewriteMonad NormalizeState Term
go
  else
    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
    [ "WARNING:", $(curLoc), "specializing a function on a non work-free"
    , "cast. Generated HDL implementation might contain duplicate work."
    , "Please report this as a bug.", "\n\nExpression where this occured:"
    , "\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
e
    ])
argCastSpec _ e :: 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 _ (_, (Cast (Term -> Term
stripTicks -> Var {}) _ _)) = Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
    test _ _ = 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 _ c :: Term
c@(Cast (Term -> Term
stripTicks -> Cast e :: Term
e tyA :: Kind
tyA tyB :: Kind
tyB) tyB' :: Kind
tyB' tyC :: 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
          (nm :: Id
nm,sp :: SrcSpan
sp) <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra. Lens' (RewriteState extra) (Id, SrcSpan)
curFun
          ClashException -> RewriteMonad NormalizeState b
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall p. PrettyPrec p => p -> String
showPpr Id
nm
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": 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 _ e :: 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 is0 :: InScopeSet
is0 _) unchanged :: Term
unchanged@(Letrec vs :: [LetBinding]
vs e' :: Term
e') = do
  (vss' :: [[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 isN :: InScopeSet
isN x :: LetBinding
x@(nm :: Id
nm, e :: Term
e) = case Term -> Term
stripTicks Term
e of
      Cast (Var {}) _ _  -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]  -- already work-free
      Cast (Cast {}) _ _ -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]  -- casts will be eliminated
      Cast e0 :: Term
e0 ty1 :: Kind
ty1 ty2 :: 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
        Id
nm' <- InScopeSet
-> TyConMap -> Name Term -> Term -> RewriteMonad extra Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
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
$ Id -> Name Term
forall a. Var a -> Name a
varName Id
nm)) Term
e0
        [LetBinding] -> RewriteMonad extra [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed [(Id
nm',Term
e0)
                ,(Id
nm, Term -> Kind -> Kind -> Term
Cast (Id -> Term
Var Id
nm') Kind
ty1 Kind
ty2)
                ]
      _ -> [LetBinding] -> RewriteMonad extra [LetBinding]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [LetBinding
x]

splitCastWork _ e :: 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 _ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Var f :: Id
f,args :: [Either Term Kind]
args@(_:_),ticks :: [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
    let isSignal :: Bool
isSignal = TyConMap -> Kind -> Bool
isSignalType TyConMap
tcm Kind
eTy
    let lv :: Bool
lv = Id -> Bool
forall a. Var a -> Bool
isLocalId Id
f
    if Bool
untranslatable Bool -> Bool -> Bool
|| Bool
isSignal Bool -> Bool -> Bool
|| Bool
argsHaveWork 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
bndrs <- Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
bindings
        case Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f VarEnv Binding
bndrs of
          -- Don't inline recursive expressions
          Just b :: Binding
b -> do
            Bool
isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
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
bindingTerm Binding
b) (Id -> TickInfo
mkInlineTick Id
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

          _ -> 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 e' :: Term
e' = do
      let fvIds :: [Id]
fvIds = Getting (Endo [Id]) Term Id -> Term -> [Id]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [Id]) Term Id
Fold Term Id
freeLocalIds Term
e'
      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 ([Id] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Id]
fvIds) Bool -> Bool -> Bool
|| Bool
isSignal)

inlineWorkFree _ e :: Term
e@(Var f :: Id
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      = Id -> Kind
forall a. Var a -> Kind
varType Id
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
  UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (Var Any))
topEntities
  let gv :: Bool
gv = Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
f
  if Bool
closed Bool -> Bool -> Bool
&& Id
f Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (Var Any)
topEnts Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
untranslatable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isSignal Bool -> Bool -> Bool
&& Bool
gv
    then do
      VarEnv Binding
bndrs <- Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
bindings
      case Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f VarEnv Binding
bndrs of
        -- Don't inline recursive expressions
        Just top :: Binding
top -> do
          Bool
isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
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
bindingTerm Binding
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
b <- Bool -> Id -> Binding -> NormalizeSession Binding
normalizeTopLvlBndr Bool
False Id
f Binding
top
                Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Binding -> Term
bindingTerm Binding
b)
        _ -> 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 _ e :: 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 _ e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Var f :: Id
f,args :: [Either Term Kind]
args,ticks :: [TickInfo]
ticks)) = do
  Bool
untranslatable <- Bool -> Term -> RewriteMonad NormalizeState Bool
forall extra. Bool -> Term -> RewriteMonad extra Bool
isUntranslatable Bool
True Term
e
  UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (Var Any))
topEntities
  let lv :: Bool
lv = Id -> Bool
forall a. Var a -> Bool
isLocalId Id
f
  if Bool
untranslatable Bool -> Bool -> Bool
|| Id
f Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
topEnts Bool -> Bool -> Bool
|| Bool
lv
    then Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    else do
      VarEnv Binding
bndrs <- Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
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 Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f VarEnv Binding
bndrs of
        -- Don't inline recursive expressions
        Just b :: Binding
b -> do
          Bool
isRecBndr <- Id -> RewriteMonad NormalizeState Bool
isRecursiveBndr Id
f
          if Bool -> Bool
not Bool
isRecBndr Bool -> Bool -> Bool
&& Binding -> InlineSpec
bindingSpec Binding
b InlineSpec -> InlineSpec -> Bool
forall a. Eq a => a -> a -> Bool
/= InlineSpec
NoInline Bool -> Bool -> Bool
&& Term -> Word
termSize (Binding -> Term
bindingTerm Binding
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
bindingTerm Binding
b) (Id -> TickInfo
mkInlineTick Id
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

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

inlineSmall _ e :: 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 is0 :: InScopeSet
is0 tfCtx :: Context
tfCtx) e :: Term
e@(App e1 :: Term
e1 e2 :: Term
e2)
  | (Var {}, args :: [Either Term Kind]
args) <- Term -> (Term, [Either Term Kind])
collectArgs Term
e1
  , (_, []) <- [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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 (LetBinding -> Id
forall a b. (a, b) -> a
fst (LetBinding -> Id) -> [LetBinding] -> [Id]
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 _ e :: 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 is :: InScopeSet
is _) = \case
  e :: Term
e@App {}
    | let (fun :: Term
fun,args :: [Either Term Kind]
args,ticks :: [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 (fun :: Term
fun,args :: [Either Term Kind]
args,ticks :: [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          -> 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 is0 :: InScopeSet
is0 (Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (fun :: Term
fun,args0 :: [Either Term Kind]
args0@(_:_),ticks0 :: [TickInfo]
ticks0)) args1 :: [Either Term Kind]
args1 ticks1 :: [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 is0 :: InScopeSet
is0 (Lam v :: Id
v e :: Term
e) (Left arg :: Term
arg:args :: [Either Term Kind]
args) ticks :: [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    if Term -> Bool
isWorkFree Term
arg Bool -> Bool -> Bool
|| Term -> Bool
isVar Term
arg
      then do
        let subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is0) Id
v Term
arg
        (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 "appPropFast.AppLam" Subst
subst Term
e) [Either Term Kind]
args []
      else do
        let is1 :: InScopeSet
is1 = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
v
        [LetBinding] -> Term -> Term
Letrec [(Id
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 is0 :: InScopeSet
is0 (Letrec vs :: [LetBinding]
vs e :: Term
e) args :: [Either Term Kind]
args@(_:_) ticks :: [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    let vbs :: [Id]
vbs  = (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
vs
        is1 :: InScopeSet
is1  = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Id]
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 is0 :: InScopeSet
is0 (TyLam tv :: TyVar
tv e :: Term
e) (Right t :: Kind
t:args :: [Either Term Kind]
args) ticks :: [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 "appPropFast.TyAppTyLam" Subst
subst Term
e) [Either Term Kind]
args []

  go is0 :: InScopeSet
is0 (Case scrut :: Term
scrut ty0 :: Kind
ty0 alts :: [Alt]
alts) args0 :: [Either Term Kind]
args0@(_:_) ticks :: [TickInfo]
ticks = do
    RewriteMonad NormalizeState ()
forall extra. RewriteMonad extra ()
setChanged
    let isA1 :: InScopeSet
isA1 = InScopeSet -> InScopeSet -> InScopeSet
unionInScope
                 InScopeSet
is0
                 ((UniqSet (Var Any) -> InScopeSet
mkInScopeSet (UniqSet (Var Any) -> InScopeSet)
-> ([Alt] -> UniqSet (Var Any)) -> [Alt] -> InScopeSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Var Any] -> UniqSet (Var Any)
forall a. [Var a] -> UniqSet (Var Any)
mkVarSet ([Var Any] -> UniqSet (Var Any))
-> ([Alt] -> [Var Any]) -> [Alt] -> UniqSet (Var Any)
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)
    (ty1 :: Kind
ty1,vs :: [LetBinding]
vs,args1 :: [Either Term Kind]
args1) <- InScopeSet
-> Kind
-> [LetBinding]
-> [Either Term Kind]
-> RewriteMonad
     NormalizeState (Kind, [LetBinding], [Either Term Kind])
forall (m :: Type -> Type).
(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
      _  -> do
        let vbs :: [Id]
vbs   = (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
vs
            is1 :: InScopeSet
is1   = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Id]
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 is0 :: InScopeSet
is0 (Tick sp :: TickInfo
sp e :: Term
e) args :: [Either Term Kind]
args ticks :: [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 _ fun :: Term
fun args :: [Either Term Kind]
args ticks :: [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 is0 :: InScopeSet
is0 args0 :: [Either Term Kind]
args0 (p :: Pat
p,e :: Term
e) = do
    let (tvs :: [TyVar]
tvs,ids :: [Id]
ids) = Pat -> ([TyVar], [Id])
patIds Pat
p
        is1 :: InScopeSet
is1       = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList (InScopeSet -> [TyVar] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [TyVar]
tvs) [Id]
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 isA :: InScopeSet
isA ty0 :: Kind
ty0 ls0 :: [LetBinding]
ls0 (Right t :: Kind
t:args0 :: [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
    (ty2 :: Kind
ty2,ls1 :: [LetBinding]
ls1,args1 :: [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 isA0 :: InScopeSet
isA0 ty0 :: Kind
ty0 ls0 :: [LetBinding]
ls0 (Left arg :: Term
arg:args0 :: [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 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
    case Term -> Bool
isWorkFree Term
arg Bool -> Bool -> Bool
|| Term -> Bool
isVar Term
arg of
      True -> do
        (ty2 :: Kind
ty2,ls1 :: [LetBinding]
ls1,args1 :: [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)
      False -> do
        Id
boundArg <- InScopeSet -> TyConMap -> Name Term -> Term -> m Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
isA0 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx "app_arg") Term
arg
        let isA1 :: InScopeSet
isA1 = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
isA0 Id
boundArg
        (ty2 :: Kind
ty2,ls1 :: [LetBinding]
ls1,args1 :: [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,(Id
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 (Id -> Term
Var Id
boundArg)Either Term Kind -> [Either Term Kind] -> [Either Term Kind]
forall a. a -> [a] -> [a]
:[Either Term Kind]
args1)

  goCaseArg _ ty :: Kind
ty ls :: [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 _ e :: Term
e@(Case (Term -> Maybe (Term, Term)
collectEqArgs -> Just (scrut' :: Term
scrut',_)) ty :: Kind
ty _)
  = do
       case Term -> Term -> Maybe [Alt]
collectFlat Term
scrut' Term
e of
         Just alts' :: [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'))
         Nothing    -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

caseFlat _ e :: 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 scrut :: Term
scrut (Case (Term -> Maybe (Term, Term)
collectEqArgs -> Just (scrut' :: Term
scrut', val :: Term
val)) _ty :: Kind
_ty [lAlt :: Alt
lAlt,rAlt :: 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 p :: PrimInfo
p,args' :: [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 dc :: DataCon
dc,args' :: [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
== "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')
      _ -> Maybe [Alt]
forall a. Maybe a
Nothing
  where
    go :: Either Term b -> Maybe [Alt]
go (Left (Literal i :: Literal
i)) = case (Alt
lAlt,Alt
rAlt) of
              ((pl :: Pat
pl,el :: Term
el),(pr :: Pat
pr,er :: 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 alts' :: [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')
                     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 alts' :: [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')
                     Nothing    -> [Alt] -> Maybe [Alt]
forall a. a -> Maybe a
Just [(Literal -> Pat
LitPat Literal
i, Term
el)
                                        ,(Pat
DefaultPat, Term
er)
                                        ]
    go _ = Maybe [Alt]
forall a. Maybe a
Nothing

    isFalseDcPat :: Pat -> Bool
isFalseDcPat (DataPat p :: DataCon
p _ _)
      = ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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 _ = Bool
False

    isTrueDcPat :: Pat -> Bool
isTrueDcPat (DataPat p :: DataCon
p _ _)
      = ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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 _ = Bool
False

collectFlat _ _ = 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 p :: PrimInfo
p, args :: [Either Term Kind]
args, ticks :: [TickInfo]
ticks))
  | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.BitVector.eq#"
    = let [_,_,Left scrut :: Term
scrut,Left val :: 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
== "Clash.Sized.Internal.Index.eq#"  Bool -> Bool -> Bool
||
    Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Signed.eq#" Bool -> Bool -> Bool
||
    Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.Unsigned.eq#"
    = let [_,Left scrut :: Term
scrut,Left val :: 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
== "Clash.Transformations.eqInt"
    = let [Left scrut :: Term
scrut,Left val :: 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 _ = 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 bs :: [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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
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 bs :: [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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
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 tcm :: TyConMap
tcm ty :: Kind
ty = case Kind -> TypeView
tyView (TyConMap -> Kind -> Kind
coreView TyConMap
tcm Kind
ty) of
  TyConApp tcNm :: TyConName
tcNm args :: [Kind]
args
    | TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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
== "GHC.Prim.(#,#)"
    , [_,_,st :: Kind
st,_] <- [Kind]
args
    -> TyConMap -> Kind -> Bool
isStateTokenTy TyConMap
tcm Kind
st
  FunTy _ res :: Kind
res -> TyConMap -> Kind -> Bool
isSimIOTy TyConMap
tcm Kind
res
  _ -> Bool
False

-- | Is the given type the state token
isStateTokenTy
  :: TyConMap
  -> Type
  -- ^ Type to check for state tokenness
  -> Bool
isStateTokenTy :: TyConMap -> Kind -> Bool
isStateTokenTy tcm :: TyConMap
tcm ty :: Kind
ty = case Kind -> TypeView
tyView (TyConMap -> Kind -> Kind
coreView TyConMap
tcm Kind
ty) of
  TyConApp tcNm :: TyConName
tcNm _ -> TyConName -> Text
forall a. Name a -> Text
nameOcc TyConName
tcNm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "GHC.Prim.State#"
  _ -> 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 is0 :: InScopeSet
is0 ctx :: Context
ctx) (Lam bndr :: Id
bndr e :: Term
e) = do
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
makeANF (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
bndr)
                                  (Id -> CoreContext
LamBody Id
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 (Id -> Term -> Term
Lam Id
bndr Term
e')

makeANF _ 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 is0 :: InScopeSet
is0 _) e0 :: 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 (is2 :: InScopeSet
is2,e1 :: Term
e1) = InScopeSet -> Term -> (InScopeSet, Term)
freshenTm InScopeSet
is0 Term
e0
    ((e2 :: Term
e2,(bndrs :: [LetBinding]
bndrs,_)),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
      _  -> do
        let (e3 :: Term
e3,ticks :: [TickInfo]
ticks) = Term -> (Term, [TickInfo])
collectTicks Term
e2
            (srcTicks :: [TickInfo]
srcTicks,nmTicks :: [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 ctx :: TransformContext
ctx e :: Term
e@(App appf :: Term
appf arg :: Term
arg)
  | (conVarPrim :: Term
conVarPrim, _) <- 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
    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
    Bool
constantNoCR   <- 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 (Term -> RewriteMonad NormalizeState Bool
forall extra. Term -> RewriteMonad extra Bool
isConstantNotClockReset 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
      (False,False,False,_) -> 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
        Id
argId <- RewriteMonad NormalizeState Id
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Id
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 Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx "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 [(Id
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 (Id -> Term
Var Id
argId))
      (True,False,_,Letrec binds :: [LetBinding]
binds body :: 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)
      _ -> 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 p :: PrimInfo
p) = PrimInfo -> Text
primName PrimInfo
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Explicit.SimIO.bindSimIO#"
  isSimBind _ = Bool
False

collectANF _ (Letrec binds :: [LetBinding]
binds body :: 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
      Id
argId <- RewriteMonad NormalizeState Id
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Id
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 Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (Text -> Int -> Name Any
forall a. Text -> Int -> Name a
mkUnsafeSystemName "result" 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 [(Id
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 (Id -> Term
Var Id
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 _ e :: Term
e@(Case _ _ [(DataPat dc :: DataCon
dc _ _,_)])
  | 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
== "Clash.Signal.Internal.:-" = Term
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

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

    (subj' :: Term
subj',subjBinders :: [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
        Id
argId <- RewriteMonad NormalizeState Id
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Id
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 Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx "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 [(Id
argId,Term
subj)]
        (Term, [LetBinding])
-> StateT
     ([LetBinding], InScopeSet)
     (RewriteMonad NormalizeState)
     (Term, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id -> Term
Var Id
argId,[(Id
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 _ [] xs :: [Id]
xs,altExpr :: Term
altExpr)]
        | [Id]
xs [Id] -> 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
      _ -> 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 isSimIOAlt :: Bool
isSimIOAlt subj' :: Term
subj' alt :: Alt
alt@(DataPat dc :: DataCon
dc exts :: [TyVar]
exts xs :: [Id]
xs,altExpr :: Term
altExpr) | Bool -> Bool
not ([TyVar] -> [Id] -> Bool
forall a. [TyVar] -> [Var a] -> Bool
bindsExistentials [TyVar]
exts [Id]
xs) = do
      let lv :: Bool
lv = Term -> Bool
isLocalVar Term
altExpr
      [LetBinding]
patSels <- (Id
 -> Int
 -> StateT
      ([LetBinding], InScopeSet)
      (RewriteMonad NormalizeState)
      LetBinding)
-> [Id]
-> [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
-> Id
-> Int
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) LetBinding
doPatBndr Term
subj' DataCon
dc) [Id]
xs [0..]
      let altExprIsConstant :: Bool
altExprIsConstant = Term -> Bool
isConstant Term
altExpr
      let usesXs :: Term -> Bool
usesXs (Var n :: Id
n) = (Id -> Bool) -> [Id] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
n) [Id]
xs
          usesXs _       = 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
== 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
          Id
altId <- RewriteMonad NormalizeState Id
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Id
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 Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx "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]
++ [(Id
altId,Term
altExpr)])
          Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataCon -> [TyVar] -> [Id] -> Pat
DataPat DataCon
dc [TyVar]
exts [Id]
xs,Id -> Term
Var Id
altId)
    doAlt _ _ alt :: Alt
alt@(DataPat {}, _) = Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return Alt
alt
    doAlt isSimIOAlt :: Bool
isSimIOAlt _ alt :: Alt
alt@(pat :: Pat
pat,altExpr :: 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
          Id
altId <- RewriteMonad NormalizeState Id
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Id
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 Id
forall (m :: Type -> Type) a.
(MonadUnique m, MonadFail m) =>
InScopeSet -> TyConMap -> Name a -> Term -> m Id
mkTmBinderFor InScopeSet
is1 TyConMap
tcm (TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx "case_alt") Term
altExpr)
          [LetBinding]
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) ()
forall (m :: Type -> Type).
Monad m =>
[LetBinding] -> StateT ([LetBinding], InScopeSet) m ()
tellBinders [(Id
altId,Term
altExpr)]
          Alt
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) Alt
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Pat
pat,Id -> Term
Var Id
altId)

    doPatBndr
      :: Term -> DataCon -> Id -> Int
      -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState)
                LetBinding
    doPatBndr :: Term
-> DataCon
-> Id
-> Int
-> StateT
     ([LetBinding], InScopeSet) (RewriteMonad NormalizeState) LetBinding
doPatBndr subj' :: Term
subj' dc :: DataCon
dc pId :: Id
pId i :: 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, Functor m, MonadUnique m) =>
String -> InScopeSet -> TyConMap -> Term -> Int -> Int -> m Term
mkSelectorCase ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 (Id
pId,Term
patExpr)

collectANF _ e :: 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 is0 :: InScopeSet
is0 ctx :: Context
ctx) (Lam bndr :: Id
bndr e :: Term
e) = do
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL
          (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
bndr) (Id -> CoreContext
LamBody Id
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
$ Id -> Term -> Term
Lam Id
bndr Term
e'

etaExpansionTL (TransformContext is0 :: InScopeSet
is0 ctx :: Context
ctx) (Letrec xes :: [LetBinding]
xes e :: Term
e) = do
  let bndrs :: [Id]
bndrs = (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
xes
  Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL
          (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 [Id]
bndrs)
                            ([Id] -> CoreContext
LetBody [Id]
bndrsCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
          Term
e
  case Term -> ([Id], Term)
stripLambda Term
e' of
    (bs :: [Id]
bs@(_:_),e2 :: 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 -> [Id] -> Term
mkLams Term
e3 [Id]
bs)
    _ -> 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 -> ([Id], Term)
stripLambda (Lam bndr :: Id
bndr e0 :: Term
e0) =
      let (bndrs :: [Id]
bndrs,e1 :: Term
e1) = Term -> ([Id], Term)
stripLambda Term
e0
      in  (Id
bndrId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs,Term
e1)
    stripLambda e' :: Term
e' = ([],Term
e')

etaExpansionTL (TransformContext is0 :: InScopeSet
is0 ctx :: Context
ctx) e :: 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
        Id
newId <- InScopeSet -> Text -> Kind -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m Id
mkInternalVar InScopeSet
is0 "arg" Kind
argTy
        Term
e' <- HasCallStack => NormRewrite
NormRewrite
etaExpansionTL (InScopeSet -> Context -> TransformContext
TransformContext (InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
is0 Id
newId)
                                               (Id -> CoreContext
LamBody Id
newIdCoreContext -> Context -> Context
forall a. a -> [a] -> [a]
:Context
ctx))
                             (Term -> Term -> Term
App Term
e (Id -> Term
Var Id
newId))
        Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Id -> Term -> Term
Lam Id
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 is0 :: InScopeSet
is0 ctx :: Context
ctx) e :: Term
e@(Term -> (Term, [Either Term Kind])
collectArgs -> (Var f :: Id
f, _)) = do
  UniqSet (Var Any)
topEnts <- Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
-> RewriteMonad NormalizeState (UniqSet (Var Any))
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (UniqSet (Var Any)) RewriteEnv (UniqSet (Var Any))
Lens' RewriteEnv (UniqSet (Var Any))
topEntities
  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 = Id
f Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`elemVarSet` UniqSet (Var Any)
topEnts
      isAppFunCtx :: Context -> Bool
isAppFunCtx =
        \case
          AppFun:_ -> Bool
True
          TickC _:c :: Context
c -> Context -> Bool
isAppFunCtx Context
c
          _ -> 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 argTy :: Kind
argTy | Bool
isTopEnt Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
isAppFunCtx Context
ctx) -> do
      Id
newId <- InScopeSet -> Text -> Kind -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m Id
mkInternalVar InScopeSet
is0 "arg" Kind
argTy
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Id -> Term -> Term
Lam Id
newId (Term -> Term -> Term
App Term
e (Id -> Term
Var Id
newId)))
    _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

etaExpandSyn _ e :: 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 nm0 :: TyConName
nm0 _) =
  if -- Constraint tuple:
     | "GHC.Classes.(%" Text -> Text -> Bool
`Text.isInfixOf` Text
nm1 -> Bool
True
     -- Constraint class:
     | "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
nm1)

isClassConstraint _ = 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 is0 :: InScopeSet
is0 []) e :: Term
e = do
  (fn :: Id
fn,_) <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra. Lens' (RewriteState extra) (Id, 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 ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
e of
    Right (args :: [Id]
args,bndrs :: [LetBinding]
bndrs,res :: Id
res) -> do
      let args' :: [Term]
args'             = (Id -> Term) -> [Id] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Term
Var [Id]
args
          (toInline :: [LetBinding]
toInline,others :: [LetBinding]
others) = (LetBinding -> Bool)
-> [LetBinding] -> ([LetBinding], [LetBinding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (TyConMap -> Id -> [Term] -> Term -> Bool
eqApp TyConMap
tcm Id
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              = Id -> Term
Var Id
res
      case ([LetBinding]
toInline,[LetBinding]
others) of
        (_:_,_:_) -> do
          let is1 :: InScopeSet
is1          = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
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 "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 -> [Id] -> Term
mkLams ([LetBinding] -> Term -> Term
Letrec [LetBinding]
others' Term
resV) [Id]
args
        _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
    _ -> 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 -> Id -> [Term] -> Term -> Bool
eqApp tcm :: TyConMap
tcm v :: Id
v args :: [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 v' :: Id
v',args' :: [Either Term Kind]
args'))
      | Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
v'
      , Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
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 _ _ _ _ = Bool
False

    eqArg :: TyConMap -> Term -> Term -> Bool
eqArg _ v1 :: Term
v1 v2 :: Term
v2@(Term -> Term
stripTicks -> Var {})
      = Term
v1 Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
v2
    eqArg tcm :: TyConMap
tcm v1 :: 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 _, args' :: [Either Term Kind]
args'))
      | let t1 :: Kind
t1 = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
v1
      , let t2 :: Kind
t2 = 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 [0..]) ([Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args'))
    eqArg _ _ _
      = 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 v :: Term
v fTrace :: [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 _, args :: [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) [0..]) ([Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Kind]
args))
    eqDat v1 :: Term
v1 fTrace :: [Int]
fTrace v2 :: 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
        _ -> Bool
False

    stripProjection :: [Int] -> Term -> Term -> Maybe [Int]
    stripProjection :: [Int] -> Term -> Term -> Maybe [Int]
stripProjection fTrace0 :: [Int]
fTrace0 vTarget0 :: Term
vTarget0 (Case v :: Term
v _ [(DataPat _ _ xs :: [Id]
xs, r :: 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] -> Maybe Int
forall a. [a] -> Maybe a
headMaybe [Int]
fTrace1
      Id
vTarget1 <- [Id] -> Int -> Maybe Id
forall a. [a] -> Int -> Maybe a
indexMaybe [Id]
xs Int
n
      [Int]
fTrace2 <- [Int] -> Maybe [Int]
forall a. [a] -> Maybe [a]
tailMaybe [Int]
fTrace1

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

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

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

recToLetRec _ e :: 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 _ e :: Term
e@(App _ _)
  | (Var f :: Id
f, args :: [Either Term Kind]
args, ticks :: [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 (cf :: Id
cf,_)    <- Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
-> RewriteMonad NormalizeState (Id, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Id, SrcSpan) (RewriteState NormalizeState) (Id, SrcSpan)
forall extra. Lens' (RewriteState extra) (Id, SrcSpan)
curFun
              Maybe Int
isInlined <- State NormalizeState (Maybe Int)
-> RewriteMonad NormalizeState (Maybe Int)
forall extra a. State extra a -> RewriteMonad extra a
zoomExtra (Id -> Id -> State NormalizeState (Maybe Int)
alreadyInlined Id
f Id
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 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) ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "InlineHO: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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]
++ " times in:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
cf) (Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e)
                else do
                  Maybe Binding
bodyMaybe <- Id -> VarEnv Binding -> Maybe Binding
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
f (VarEnv Binding -> Maybe Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
-> RewriteMonad NormalizeState (Maybe Binding)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
-> RewriteMonad NormalizeState (VarEnv Binding)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (VarEnv Binding) (RewriteState NormalizeState) (VarEnv Binding)
forall extra. Lens' (RewriteState extra) (VarEnv Binding)
bindings
                  case Maybe Binding
bodyMaybe of
                    Just b :: Binding
b -> do
                      State NormalizeState () -> RewriteMonad NormalizeState ()
forall extra a. State extra a -> RewriteMonad extra a
zoomExtra (Id -> Id -> State NormalizeState ()
addNewInline Id
f Id
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
bindingTerm Binding
b) [TickInfo]
ticks) [Either Term Kind]
args)
                    _ -> 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 _ e :: 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 is0 :: InScopeSet
is0 _) (HasCallStack => Term -> Term
Term -> Term
inverseTopSortLetBindings -> Letrec bndrs :: [LetBinding]
bndrs body :: Term
body) = do
  let is1 :: InScopeSet
is1 = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
bndrs)
  (subst :: Subst
subst,bndrs1 :: [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 "simpleCSE.bndrs" Subst
subst)) [LetBinding]
bndrs1
      body1 :: Term
body1  = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "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 _ e :: 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 processed :: [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 processed :: [LetBinding]
processed ((i :: Id
i,HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "reduceBinders" Subst
subst -> Term
e):rest :: [LetBinding]
rest)
  | (_,_,ticks :: [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 (i1 :: Id
i1,_) <- (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 -> Id -> Term -> Subst
extendIdSubst Subst
subst Id
i (Id -> Term
Var Id
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 ((Id
i,Term
e)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:[LetBinding]
processed) [LetBinding]
rest
{-# SCC reduceBinders #-}

reduceConst :: HasCallStack => NormRewrite
reduceConst :: NormRewrite
reduceConst ctx :: TransformContext
ctx e :: Term
e@(App _ _)
  | (Prim p0 :: PrimInfo
p0, _) <- 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
$ \_ctx1 :: TransformContext
_ctx1 e1 :: Term
e1 -> case Term
e1 of
      (Term -> (Term, [Either Term Kind])
collectArgs -> (Prim p1 :: PrimInfo
p1, _)) | 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 -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1

reduceConst _ e :: 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#
reduceNonRepPrim :: HasCallStack => NormRewrite
reduceNonRepPrim :: NormRewrite
reduceNonRepPrim c :: TransformContext
c@(TransformContext is0 :: InScopeSet
is0 ctx :: Context
ctx) e :: Term
e@(App _ _) | (Prim p :: PrimInfo
p, args :: [Either Term Kind]
args, ticks :: [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 0, aTy :: Kind
aTy]) -> do
      let (Just vecTc :: TyCon
vecTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
vecTcNm TyConMap
tcm
          [nilCon :: DataCon
nilCon,consCon :: DataCon
consCon] = TyCon -> [DataCon]
tyConDataCons TyCon
vecTc
          nilE :: Term
nilE = DataCon -> DataCon -> Kind -> Integer -> [Term] -> Term
mkVec DataCon
nilCon DataCon
consCon Kind
aTy 0 []
      Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (Term -> [TickInfo] -> Term
mkTicks Term
nilE [TickInfo]
ticks)
    tv :: 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
      "Clash.Sized.Vector.zipWith" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 7 -> do
        let [lhsElTy :: Kind
lhsElTy,rhsElty :: Kind
rhsElty,resElTy :: Kind
resElTy,nTy :: Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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
anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly
                                        [Kind
lhsElTy,Kind
rhsElty,Kind
resElTy] ]
            if Bool
shouldReduce1
               then let [fun :: Term
fun,lhsArg :: Term
lhsArg,rhsArg :: 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
-> Integer
-> Kind
-> Kind
-> Kind
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceZipWith TransformContext
c 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.map" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 5 -> do
        let [argElTy :: Kind
argElTy,resElTy :: Kind
resElTy,nTy :: Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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
anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly
                                        [Kind
argElTy,Kind
resElTy] ]
            if Bool
shouldReduce1
               then let [fun :: Term
fun,arg :: 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
reduceMap 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.traverse#" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 7 ->
        let [aTy :: Kind
aTy,fTy :: Kind
fTy,bTy :: Kind
bTy,nTy :: 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 n :: Integer
n ->
            let [dict :: Term
dict,fun :: Term
fun,arg :: 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.fold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 -> do
        let [aTy :: Kind
aTy,nTy :: Kind
nTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly Kind
aTy ]
            if Bool
shouldReduce1 then
              let [fun :: Term
fun,arg :: 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
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceFold TransformContext
c (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.foldr" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 6 ->
        let [aTy :: Kind
aTy,bTy :: Kind
bTy,nTy :: 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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 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
anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly [Kind
aTy,Kind
bTy] ]
            if Bool
shouldReduce1
              then let [fun :: Term
fun,start :: Term
start,arg :: 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
-> Term
-> Term
-> Term
-> RewriteMonad NormalizeState Term
reduceFoldr TransformContext
c 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.dfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 8 ->
        let ([_kn :: Term
_kn,_motive :: Term
_motive,fun :: Term
fun,start :: Term
start,arg :: Term
arg],[_mTy :: Kind
_mTy,nTy :: Kind
nTy,aTy :: 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 n :: 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.++" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 5 ->
        let [nTy :: Kind
nTy,aTy :: Kind
aTy,mTy :: Kind
mTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [lArg :: Term
lArg,rArg :: 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 n :: Integer
n, Right m :: Integer
m)
                | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 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
== 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
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                         , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> 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
              _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.head" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> do
        let [nTy :: Kind
nTy,aTy :: Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [vArg :: Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceHead InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.tail" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> do
        let [nTy :: Kind
nTy,aTy :: Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [vArg :: Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceTail InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.last" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> do
        let [nTy :: Kind
nTy,aTy :: Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [vArg :: Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceLast InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.init" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> do
        let [nTy :: Kind
nTy,aTy :: Kind
aTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [Either Term Kind]
args
            [vArg :: Term
vArg]    = [Either Term Kind] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> InScopeSet
-> Integer -> Kind -> Term -> RewriteMonad NormalizeState Term
reduceInit InScopeSet
is0 (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) Kind
aTy Term
vArg
               else Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.unconcat" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 6 -> do
        let ([_knN :: Term
_knN,_sm :: Term
_sm,arg :: Term
arg],[mTy :: Kind
mTy,nTy :: Kind
nTy,aTy :: 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 n :: Integer
n, Right 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 0 Kind
aTy Term
arg
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.transpose" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 5 -> do
        let ([_knN :: Term
_knN,arg :: Term
arg],[mTy :: Kind
mTy,nTy :: Kind
nTy,aTy :: 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 n :: Integer
n, Right 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 0 Kind
aTy Term
arg
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.replicate" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 -> do
        let ([_sArg :: Term
_sArg,vArg :: Term
vArg],[nTy :: Kind
nTy,aTy :: 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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [ Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
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
          _ -> 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
      "Clash.Sized.Vector.replace_int" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 6 -> do
        let ([_knArg :: Term
_knArg,vArg :: Term
vArg,iArg :: Term
iArg,aArg :: Term
aArg],[nTy :: Kind
nTy,aTy :: 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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 Bool
ultra
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      "Clash.Sized.Vector.index_int" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 5 -> do
        let ([_knArg :: Term
_knArg,vArg :: Term
vArg,iArg :: Term
iArg],[nTy :: Kind
nTy,aTy :: 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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 Bool
ultra
                                 , Context -> RewriteMonad NormalizeState Bool
shouldReduce Context
ctx
                                 , Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly 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
<$> 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      "Clash.Sized.Vector.imap" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 6 -> do
        let [nTy :: Kind
nTy,argElTy :: Kind
argElTy,resElTy :: Kind
resElTy] = [Either Term Kind] -> [Kind]
forall a b. [Either a b] -> [b]
Either.rights [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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [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 (Bool
ultra Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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
anyM Kind -> RewriteMonad NormalizeState Bool
forall extra. Kind -> RewriteMonad extra Bool
isUntranslatableType_not_poly [Kind
argElTy,Kind
resElTy] ]
            if Bool
shouldReduce1
               then let [_,fun :: Term
fun,arg :: 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Vector.dtfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 8 ->
        let ([_kn :: Term
_kn,_motive :: Term
_motive,lrFun :: Term
lrFun,brFun :: Term
brFun,arg :: Term
arg],[_mTy :: Kind
_mTy,nTy :: Kind
nTy,aTy :: 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 n :: 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e

      "Clash.Sized.Vector.reverse"
        | Bool
ultra
        , ([vArg :: Term
vArg],[nTy :: Kind
nTy,aTy :: Kind
aTy]) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        , Right n :: 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

      "Clash.Sized.RTree.tdfold" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 8 ->
        let ([_kn :: Term
_kn,_motive :: Term
_motive,lrFun :: Term
lrFun,brFun :: Term
brFun,arg :: Term
arg],[_mTy :: Kind
_mTy,nTy :: Kind
nTy,aTy :: 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 n :: 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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.RTree.treplicate" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 -> do
        let ([_sArg :: Term
_sArg,vArg :: Term
vArg],[nTy :: Kind
nTy,aTy :: 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 n :: Integer
n -> do
            Bool
shouldReduce1 <- [RewriteMonad NormalizeState Bool]
-> RewriteMonad NormalizeState Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
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
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Internal.BitVector.split#" | Int
argLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 -> do
        let ([_knArg :: Term
_knArg,bvArg :: Term
bvArg],[nTy :: Kind
nTy,mTy :: 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 n :: Integer
n, Right m :: Integer
m, TyConApp tupTcNm :: TyConName
tupTcNm [lTy :: Kind
lTy,rTy :: Kind
rTy])
            | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> do
              let (Just tupTc :: TyCon
tupTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tupTcNm TyConMap
tcm
                  [tupDc :: 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
== 0 -> do
              let (Just tupTc :: TyCon
tupTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tupTcNm TyConMap
tcm
                  [tupDc :: 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)
          _ -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      "Clash.Sized.Internal.BitVector.eq#"
        | ([_,_],[nTy :: Kind
nTy]) <- [Either Term Kind] -> ([Term], [Kind])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers [Either Term Kind]
args
        , Right 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 boolTcNm :: TyConName
boolTcNm [] <- TypeView
tv
        -> let (Just boolTc :: TyCon
boolTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
boolTcNm TyConMap
tcm
               [_falseDc :: DataCon
_falseDc,trueDc :: 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)
      _ -> 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 t :: 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 _ e :: 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 is0 :: InScopeSet
is0 _) e :: Term
e@(Case _scrut :: Term
_scrut _ty :: Kind
_ty _alts :: [Alt]
_alts@(_:_:_)) = do
    (_,collected :: [(Term, ([Term], CaseTree [Either Term Kind]))]
collected) <- InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
is0 [] [] Term
e
    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
         [(Term, [Term])]
exprs <- ((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
is0) [(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
         [Id]
lids  <- ((Term, ([Term], CaseTree [Either Term Kind]))
 -> (Term, [Term]) -> RewriteMonad NormalizeState Id)
-> [(Term, ([Term], CaseTree [Either Term Kind]))]
-> [(Term, [Term])]
-> RewriteMonad NormalizeState [Id]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
Monad.zipWithM (InScopeSet
-> TyConMap
-> (Term, ([Term], CaseTree [Either Term Kind]))
-> (Term, [Term])
-> RewriteMonad NormalizeState Id
forall (m :: Type -> Type) b b.
MonadUnique m =>
InScopeSet -> TyConMap -> (Term, b) -> (Term, b) -> m Id
mkFunOut InScopeSet
is0 TyConMap
tcm) [(Term, ([Term], CaseTree [Either Term Kind]))]
disJoint [(Term, [Term])]
exprs
         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) ((Id -> Term) -> [Id] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Term
Var [Id]
lids)
             subsMatrix :: [[(Term, Term)]]
subsMatrix   = [(Term, Term)] -> [[(Term, Term)]]
forall a. [a] -> [[a]]
l2m [(Term, Term)]
substitution
         (exprs' :: [Term]
exprs',_) <- [(Term, [(Term, ([Term], CaseTree [Either Term Kind]))])]
-> ([Term], [[(Term, ([Term], CaseTree [Either Term Kind]))]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Term, [(Term, ([Term], CaseTree [Either Term Kind]))])]
 -> ([Term], [[(Term, ([Term], CaseTree [Either Term Kind]))]]))
-> RewriteMonad
     NormalizeState
     [(Term, [(Term, ([Term], CaseTree [Either Term Kind]))])]
-> RewriteMonad
     NormalizeState
     ([Term], [[(Term, ([Term], CaseTree [Either Term Kind]))]])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Term, Term)]
 -> (Term, [Term])
 -> RewriteMonad
      NormalizeState
      (Term, [(Term, ([Term], CaseTree [Either Term Kind]))]))
-> [[(Term, Term)]]
-> [(Term, [Term])]
-> RewriteMonad
     NormalizeState
     [(Term, [(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
                        (\s :: [(Term, Term)]
s (e' :: Term
e',seen :: [Term]
seen) -> InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
is0 [(Term, Term)]
s [Term]
seen Term
e')
                        [[(Term, Term)]]
subsMatrix
                        [(Term, [Term])]
exprs
         (e' :: Term
e',_) <- InScopeSet
-> [(Term, Term)]
-> [Term]
-> Term
-> RewriteMonad
     NormalizeState
     (Term, [(Term, ([Term], CaseTree [Either Term Kind]))])
collectGlobals InScopeSet
is0 [(Term, Term)]
substitution [] Term
e
         let lb :: Term
lb = [LetBinding] -> Term -> Term
Letrec ([Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
lids [Term]
exprs') Term
e'
         Term
lb' <- 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
lb'
  where
    mkFunOut :: InScopeSet -> TyConMap -> (Term, b) -> (Term, b) -> m Id
mkFunOut isN :: InScopeSet
isN tcm :: TyConMap
tcm (fun :: Term
fun,_) (e' :: Term
e',_) = do
      let ty :: Kind
ty  = TyConMap -> Term -> Kind
termType TyConMap
tcm Term
e'
          nm :: Text
nm  = case Term -> (Term, [Either Term Kind])
collectArgs Term
fun of
                   (Var v :: Id
v,_)      -> Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
v)
                   (Prim p :: PrimInfo
p,_) -> PrimInfo -> Text
primName PrimInfo
p
                   _             -> "complex_expression_"
          nm'' :: Text
nm'' = [Text] -> Text
forall a. [a] -> a
last (Text -> Text -> [Text]
Text.splitOn "." Text
nm) Text -> Text -> Text
`Text.append` "Out"
      InScopeSet -> Text -> Kind -> m Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m Id
mkInternalVar InScopeSet
isN Text
nm'' Kind
ty

    l2m :: [a] -> [[a]]
l2m = [a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
go []
      where
        go :: [a] -> [a] -> [[a]]
go _  []     = []
        go xs :: [a]
xs (y :: a
y:ys :: [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 _ e :: 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 is0 :: InScopeSet
is0 _) (Letrec binds :: [LetBinding]
binds body :: 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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
binds)
      bindsFvs :: [(Id, (LetBinding, VarEnv Int))]
bindsFvs  = (LetBinding -> (Id, (LetBinding, VarEnv Int)))
-> [LetBinding] -> [(Id, (LetBinding, VarEnv Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Id
v,e :: Term
e) -> (Id
v,((Id
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
$ ((Id, (LetBinding, VarEnv Int)) -> VarEnv Int)
-> [(Id, (LetBinding, VarEnv Int))] -> [VarEnv Int]
forall a b. (a -> b) -> [a] -> [b]
map ((LetBinding, VarEnv Int) -> VarEnv Int
forall a b. (a, b) -> b
snd((LetBinding, VarEnv Int) -> VarEnv Int)
-> ((Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int))
-> (Id, (LetBinding, VarEnv Int))
-> VarEnv Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
forall a b. (a, b) -> b
snd) [(Id, (LetBinding, VarEnv Int))]
bindsFvs
      bodyFVs :: UniqSet (Var Any)
bodyFVs   = Getting (UniqSet (Var Any)) Term Id
-> (Id -> UniqSet (Var Any)) -> Term -> UniqSet (Var Any)
forall r s a. Getting r s a -> (a -> r) -> s -> r
Lens.foldMapOf Getting (UniqSet (Var Any)) Term Id
Fold Term Id
freeLocalIds Id -> UniqSet (Var Any)
forall a. Var a -> UniqSet (Var Any)
unitVarSet Term
body
      (il :: [(Id, (LetBinding, VarEnv Int))]
il,keep :: [(Id, (LetBinding, VarEnv Int))]
keep) = ((Id, (LetBinding, VarEnv Int)) -> Bool)
-> [(Id, (LetBinding, VarEnv Int))]
-> ([(Id, (LetBinding, VarEnv Int))],
    [(Id, (LetBinding, VarEnv Int))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (VarEnv Int
-> HashMap Text GuardedCompiledPrimitive
-> UniqSet (Var Any)
-> (Id, (LetBinding, VarEnv Int))
-> Bool
isInteresting VarEnv Int
allOccs HashMap Text GuardedCompiledPrimitive
prims UniqSet (Var Any)
bodyFVs)
                                 [(Id, (LetBinding, VarEnv Int))]
bindsFvs
      keep' :: [LetBinding]
keep'     = InScopeSet
-> VarEnv (LetBinding, VarEnv Int)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)]
-> [LetBinding]
inlineBndrsCleanup InScopeSet
is1 ([(Id, (LetBinding, VarEnv Int))] -> VarEnv (LetBinding, VarEnv Int)
forall a b. [(Var a, b)] -> VarEnv b
mkVarEnv [(Id, (LetBinding, VarEnv Int))]
il) VarEnv (LetBinding, VarEnv Int, Mark)
forall a. VarEnv a
emptyVarEnv
                ([(LetBinding, VarEnv Int)] -> [LetBinding])
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
forall a b. (a -> b) -> a -> b
$ ((Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int))
-> [(Id, (LetBinding, VarEnv Int))] -> [(LetBinding, VarEnv Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Id, (LetBinding, VarEnv Int)) -> (LetBinding, VarEnv Int)
forall a b. (a, b) -> b
snd [(Id, (LetBinding, VarEnv Int))]
keep

  if | [(Id, (LetBinding, VarEnv Int))] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [(Id, (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
-> UniqSet (Var Any)
-> (Id, (LetBinding, VarEnv Int))
-> Bool
isInteresting allOccs :: VarEnv Int
allOccs prims :: HashMap Text GuardedCompiledPrimitive
prims bodyFVs :: UniqSet (Var Any)
bodyFVs (id_ :: Id
id_,((_,((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),_))
      | Name Term -> NameSort
forall a. Name a -> NameSort
nameSort (Id -> Name Term
forall a. Var a -> Name a
varName Id
id_) NameSort -> NameSort -> Bool
forall a. Eq a => a -> a -> Bool
/= NameSort
User
      , Id
id_ Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (Var Any)
bodyFVs
      = case Term
tm of
          Prim pInfo :: 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 occ :: Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
allOccs
            , Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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` ["Clash.Explicit.SimIO.bindSimIO#"]
          Case _ _ [_] -> Bool
True
          Data _ -> Bool
True
          Case _ aTy :: Kind
aTy (_:_:_)
            | TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
"Clash.Explicit.SimIO.SimIO") _ <- Kind -> TypeView
tyView Kind
aTy
            -> Bool
True
          _ -> Bool
False
      | Id
id_ Id -> UniqSet (Var Any) -> Bool
forall a. Var a -> UniqSet (Var Any) -> Bool
`notElemVarSet` UniqSet (Var Any)
bodyFVs
      = case Term
tm of
          Prim pInfo :: PrimInfo
pInfo
            | PrimInfo -> Text
primName PrimInfo
pInfo Text -> [Text] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [ "Clash.Explicit.SimIO.openFile"
                        , "Clash.Explicit.SimIO.fgetc"
                        , "Clash.Explicit.SimIO.feof"
                        ]
            , Just occ :: Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id_ VarEnv Int
allOccs
            , Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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` ["Clash.Explicit.SimIO.bindSimIO#"]
          Case _ _ [(DataPat dcE :: DataCon
dcE _ _,_)]
            -> 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
== "Clash.Sized.Internal.BitVector.BV"  Bool -> Bool -> Bool
||
                  Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Clash.Sized.Internal.BitVector.Bit" Bool -> Bool -> Bool
||
                  -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset)
                  "GHC.Classes" Text -> Text -> Bool
`Text.isPrefixOf` Text
nm
          Case _ aTy :: Kind
aTy (_:_:_)
            | TyConApp (TyConName -> Text
forall a. Name a -> Text
nameOcc -> Text
"Clash.Explicit.SimIO.SimIO") _ <- Kind -> TypeView
tyView Kind
aTy
            -> Bool
True
          _ -> Bool
False

    isInteresting _ _ _ _ = Bool
False

inlineCleanup _ e :: 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
  :: 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 isN :: InScopeSet
isN origInl :: 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 doneInl :: 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.
    [ (Id
v,Term
e) | ((v :: Id
v,e :: Term
e),_,Rec) <- VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int, Mark)]
forall a. VarEnv a -> [a]
eltsVarEnv VarEnv (LetBinding, VarEnv Int, Mark)
doneInl ]
  go !VarEnv (LetBinding, VarEnv Int, Mark)
doneInl (((v :: Id
v,e :: Term
e),eFVs :: VarEnv Int
eFVs):il :: [(LetBinding, VarEnv Int)]
il) =
    let (sM :: Maybe Subst
sM,_,doneInl1 :: 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'
                            (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)
                            VarEnv Int
eFVs
        e1 :: Term
e1 = case Maybe Subst
sM of
               Nothing -> Term
e
               Just s :: Subst
s  -> HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "inlineBndrsCleanup" Subst
s Term
e
    in  (Id
v,Term
e1)LetBinding -> [LetBinding] -> [LetBinding]
forall a. a -> [a] -> [a]
:VarEnv (LetBinding, VarEnv Int, Mark)
-> [(LetBinding, VarEnv Int)] -> [LetBinding]
go VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1 [(LetBinding, VarEnv Int)]
il
{-# SCC inlineBndrsCleanup #-}

-- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into
-- the other to-inline let-binders.
reduceBindersCleanup
  :: 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 isN :: InScopeSet
isN origInl :: VarEnv (LetBinding, VarEnv Int)
origInl (!Maybe Subst
substM,!VarEnv Int
substFVs,!VarEnv (LetBinding, VarEnv Int, Mark)
doneInl) u :: Int
u _ = 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
    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
      Nothing ->
        -- let-binding not found, cannot extend the substitution
        (Maybe Subst
substM,VarEnv Int
substFVs,VarEnv (LetBinding, VarEnv Int, Mark)
doneInl)
      Just ((v :: Id
v,e :: Term
e),eFVs :: VarEnv Int
eFVs) ->
        -- Simplify the transitive dependencies
        let (sM :: Maybe Subst
sM,substFVsE :: VarEnv Int
substFVsE,doneInl1 :: 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'
                (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.
                , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e),VarEnv Int
eFVs,Mark
Temp) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl)
                VarEnv Int
eFVs

            e1 :: Term
e1 = case Maybe Subst
sM of
                   Nothing -> Term
e
                   Just s :: Subst
s  -> HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "reduceBindersCleanup" Subst
s Term
e
        in  if Id
v Id -> VarEnv Int -> Bool
forall a b. Var a -> VarEnv b -> Bool
`elemVarEnv` VarEnv Int
substFVsE then
              -- We cannot inline recursive let-bindings, so we do not extend
              -- the substitution environment.
              ( Maybe Subst
substM
              , VarEnv Int
substFVs
              -- And we explicitly mark the let-binding as recursive in the
              -- processing environment. So that it will be kept around at the
              -- end of 'inlineCleanup'
              , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e1),VarEnv Int
substFVsE,Mark
Rec) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1
              )
            else
              -- Extend the substitution
              ( Subst -> Maybe Subst
forall a. a -> Maybe a
Just (Subst -> Id -> Term -> Subst
extendIdSubst (Subst -> Maybe Subst -> Subst
forall a. a -> Maybe a -> a
Maybe.fromMaybe (InScopeSet -> Subst
mkSubst InScopeSet
isN) Maybe Subst
substM) Id
v Term
e1)
              , VarEnv Int -> VarEnv Int -> VarEnv Int
forall a. VarEnv a -> VarEnv a -> VarEnv a
unionVarEnv VarEnv Int
substFVsE VarEnv Int
substFVs
              -- Mark the let-binding a fully "reduced", so we don't repeat
              -- this process when we encounter it again.
              , Id
-> (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
-> VarEnv (LetBinding, VarEnv Int, Mark)
forall b a. Var b -> a -> VarEnv a -> VarEnv a
extendVarEnv Id
v ((Id
v,Term
e1),VarEnv Int
substFVsE,Mark
Done) VarEnv (LetBinding, VarEnv Int, Mark)
doneInl1
              )
    -- It's already been process, just extend the substitution environment
    Just ((v :: Id
v,e :: Term
e),eFVs :: VarEnv Int
eFVs,Done) ->
      ( Subst -> Maybe Subst
forall a. a -> Maybe a
Just (Subst -> Id -> Term -> Subst
extendIdSubst (Subst -> Maybe Subst -> Subst
forall a. a -> Maybe a -> a
Maybe.fromMaybe (InScopeSet -> Subst
mkSubst InScopeSet
isN) Maybe Subst
substM) Id
v Term
e)
      , VarEnv Int -> VarEnv Int -> VarEnv Int
forall a. VarEnv a -> VarEnv a -> VarEnv a
unionVarEnv VarEnv Int
eFVs VarEnv Int
substFVs
      , VarEnv (LetBinding, VarEnv Int, Mark)
doneInl
      )

    -- It's either recursive (Rec), or part of a recursive group (Temp) where we
    -- originally entered a different part of the cycle. Regardless, we do not
    -- extend the substitution environment.
    Just _ ->
      ( 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 is0 :: InScopeSet
is0 _) (Letrec binds :: [LetBinding]
binds body :: Term
body) = do
  let is1 :: InScopeSet
is1 = InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
is0 ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
binds)
      bodyOccs :: VarEnv Int
bodyOccs = Fold Term Id
-> (VarEnv Int -> VarEnv Int -> VarEnv Int)
-> VarEnv Int
-> (Id -> VarEnv Int)
-> Term
-> VarEnv Int
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
Lens.foldMapByOf
                   Fold Term Id
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 (Id -> Int -> VarEnv Int
forall b a. Var b -> a -> VarEnv a
`unitVarEnv` (1 :: Int))
                   Term
body
  (is2 :: InScopeSet
is2,binds1 :: [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])
mapAccumLM InScopeSet
-> LetBinding
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
go InScopeSet
is1 [LetBinding]
binds
  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
    [(id1 :: Id
id1,e1 :: Term
e1)] | Just occ :: Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id1 VarEnv Int
bodyOccs, Term -> Bool
isWorkFree Term
e1 Bool -> Bool -> Bool
|| Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 ->
      if Id
id1 Id -> 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 -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is2) Id
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 "flattenLet" Subst
subst Term
body)
    _ -> 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 isN :: InScopeSet
isN (id1 :: Id
id1,Term -> (Term, [TickInfo])
collectTicks -> (Letrec binds1 :: [LetBinding]
binds1 body1 :: Term
body1,ticks :: [TickInfo]
ticks)) = do
      let bs1 :: [Id]
bs1 = (LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
binds1
      let (binds2 :: [LetBinding]
binds2,body2 :: Term
body2,isN1 :: 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 (Id -> Bool) -> [Id] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (Id -> InScopeSet -> Bool
forall a. Var a -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
isN) [Id]
bs1 then
              let Letrec bindsN :: [LetBinding]
bindsN bodyN :: 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 -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
isN ((LetBinding -> Id) -> [LetBinding] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map LetBinding -> Id
forall a b. (a, b) -> a
fst [LetBinding]
bindsN))
            else
              ([LetBinding]
binds1,Term
body1,InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
extendInScopeSetList InScopeSet
isN [Id]
bs1)
      let bodyOccs :: VarEnv Int
bodyOccs = Fold Term Id
-> (VarEnv Int -> VarEnv Int -> VarEnv Int)
-> VarEnv Int
-> (Id -> VarEnv Int)
-> Term
-> VarEnv Int
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
Lens.foldMapByOf
                       Fold Term Id
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 (Id -> Int -> VarEnv Int
forall b a. Var b -> a -> VarEnv a
`unitVarEnv` (1 :: Int))
                       Term
body2
          (srcTicks :: [TickInfo]
srcTicks,nmTicks :: [TickInfo]
nmTicks) = [TickInfo] -> ([TickInfo], [TickInfo])
partitionTicks [TickInfo]
ticks
      -- 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
        [(id2 :: Id
id2,e2 :: Term
e2)] | Just occ :: Int
occ <- Id -> VarEnv Int -> Maybe Int
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
id2 VarEnv Int
bodyOccs, Term -> Bool
isWorkFree Term
e2 Bool -> Bool -> Bool
|| Int
occ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 ->
          if Id
id2 Id -> Term -> Bool
`localIdOccursIn` Term
e2
             -- Except when the binder is recursive!
             then [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed ([(Id
id2,Term
e2),(Id
id1, Term
body2)])
             else let subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
isN1) Id
id2 Term
e2
                  in  [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed [(Id
id1
                               -- Only apply srcTicks to the body
                               ,Term -> [TickInfo] -> Term
mkTicks (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "flattenLetGo" Subst
subst Term
body2)
                                        [TickInfo]
srcTicks)]
        bs :: [LetBinding]
bs -> [LetBinding] -> RewriteMonad NormalizeState [LetBinding]
forall a extra. a -> RewriteMonad extra a
changed ([LetBinding]
bs [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [(Id
id1
                               -- Only apply srcTicks to the body
                              ,Term -> [TickInfo] -> Term
mkTicks Term
body2 [TickInfo]
srcTicks)])
    go isN :: InScopeSet
isN b :: LetBinding
b = (InScopeSet, [LetBinding])
-> RewriteMonad NormalizeState (InScopeSet, [LetBinding])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (InScopeSet
isN,[LetBinding
b])

flattenLet _ e :: 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 -> Id -> Term -> Maybe Term
separateLambda tcm :: TyConMap
tcm ctx :: TransformContext
ctx@(TransformContext is0 :: InScopeSet
is0 _) b :: Id
b eb0 :: Term
eb0 =
  case TyConMap -> Kind -> Maybe (Term, [Kind])
shouldSplit TyConMap
tcm (Id -> Kind
forall a. Var a -> Kind
varType Id
b) of
    Just (dc :: Term
dc,argTys :: [Kind]
argTys@(_:_:_)) ->
      let
        nm :: Name Term
nm = TransformContext -> Text -> Name Term
mkDerivedName TransformContext
ctx (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
b))
        bs0 :: [Id]
bs0 = (Kind -> Id) -> [Kind] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> Name Term -> Id
`mkLocalId` Name Term
nm) [Kind]
argTys
        (is1 :: InScopeSet
is1, bs1 :: [Id]
bs1) = (InScopeSet -> Id -> (InScopeSet, Id))
-> InScopeSet -> [Id] -> (InScopeSet, [Id])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL InScopeSet -> Id -> (InScopeSet, Id)
forall a. InScopeSet -> Var a -> (InScopeSet, Var a)
newBinder InScopeSet
is0 [Id]
bs0
        subst :: Subst
subst = Subst -> Id -> Term -> Subst
extendIdSubst (InScopeSet -> Subst
mkSubst InScopeSet
is1) Id
b (Term -> [Either Term Kind] -> Term
mkApps Term
dc ((Id -> Either Term Kind) -> [Id] -> [Either Term Kind]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Either Term Kind
forall a b. a -> Either a b
Left (Term -> Either Term Kind)
-> (Id -> Term) -> Id -> Either Term Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Term
Var) [Id]
bs1))
        eb1 :: Term
eb1 = HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm "separateArguments" Subst
subst Term
eb0
      in
        Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> [Id] -> Term
mkLams Term
eb1 [Id]
bs1)
    _ ->
      Maybe Term
forall a. Maybe a
Nothing
 where
  newBinder :: InScopeSet -> Var a -> (InScopeSet, Var a)
newBinder isN0 :: InScopeSet
isN0 x :: 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 ctx :: TransformContext
ctx e0 :: Term
e0@(Lam b :: Id
b eb :: 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 -> Id -> Term -> Maybe Term
separateLambda TyConMap
tcm TransformContext
ctx Id
b Term
eb of
    Just e1 :: Term
e1 -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed Term
e1
    Nothing -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e0

separateArguments (TransformContext is0 :: InScopeSet
is0 _) e :: Term
e@(Term -> (Term, [Either Term Kind], [TickInfo])
collectArgsTicks -> (Var g :: Id
g, args :: [Either Term Kind]
args, ticks :: [TickInfo]
ticks))
  | Id -> Bool
forall a. Var a -> Bool
isGlobalId Id
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 (argTys0 :: [Either TyVar Kind]
argTys0,resTy :: Kind
resTy) = Kind -> ([Either TyVar Kind], Kind)
splitFunForallTy (Id -> Kind
forall a. Var a -> Kind
varType Id
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 (argTys1 :: [Either TyVar Kind]
argTys1,args2 :: [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 (Id -> Term
Var Id
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 tv :: Either TyVar Kind
tv arg :: Either Term Kind
arg@(Right _)    = [(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 ty :: Either TyVar Kind
ty arg :: Either Term Kind
arg@(Left tmArg :: 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, [Kind])
shouldSplit TyConMap
tcm Kind
argTy of
      Just (_,argTys :: [Kind]
argTys@(_:_:_)) -> do
        [Term]
tmArgs <- (Int -> RewriteMonad NormalizeState Term)
-> [Int] -> 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 (String
-> InScopeSet
-> TyConMap
-> Term
-> Int
-> Int
-> RewriteMonad NormalizeState Term
forall (m :: Type -> Type).
(HasCallStack, Functor m, MonadUnique m) =>
String -> InScopeSet -> TyConMap -> Term -> Int -> Int -> m Term
mkSelectorCase ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "splitArg") InScopeSet
is0 TyConMap
tcm Term
tmArg 1)
                       [0..[Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Kind]
argTys Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]
        [(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)
      _ ->
        [(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 _ e :: 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 is0 :: InScopeSet
is0 _) e :: Term
e@(Case subj :: Term
subj ty :: Kind
ty alts :: [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])
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
      ([], _)    -> Term -> RewriteMonad NormalizeState Term
forall (m :: Type -> Type) a. Monad m => a -> m a
return Term
e
      (_, [])    -> Term -> RewriteMonad NormalizeState Term
forall a extra. a -> RewriteMonad extra a
changed (PrimInfo -> Term
Prim (Text -> Kind -> WorkInfo -> PrimInfo
PrimInfo "Clash.XException.errorX" Kind
ty WorkInfo
WorkConstant))
      (_, [alt :: Alt
alt]) -> InScopeSet -> Term -> Alt -> RewriteMonad NormalizeState Term
xOptimizeSingle InScopeSet
is0 Term
subj Alt
alt
      (_, defs :: [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 _ e :: 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 is :: InScopeSet
is subj :: Term
subj (DataPat dc :: DataCon
dc tvs :: [TyVar]
tvs vars :: [Id]
vars, expr :: 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
  Id
subjId <- InScopeSet -> Text -> Kind -> RewriteMonad NormalizeState Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m Id
mkInternalVar InScopeSet
is "subj" (TyConMap -> Term -> Kind
termType TyConMap
tcm Term
subj)

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

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

xOptimizeSingle _ _ (_, expr :: 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 is :: InScopeSet
is subj :: Term
subj ty :: Kind
ty defs :: [Alt]
defs@(d :: Alt
d:ds :: [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 _ _ _ [] =
  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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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
-> Id -> DataCon -> [TyVar] -> [Kind] -> Id -> Int -> m LetBinding
mkFieldSelector is0 :: InScopeSet
is0 subj :: Id
subj dc :: DataCon
dc tvs :: [TyVar]
tvs fieldTys :: [Kind]
fieldTys nm :: Id
nm index :: Int
index = do
  [Id]
fields <- (Kind -> m Id) -> [Kind] -> m [Id]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ty :: Kind
ty -> InScopeSet -> Text -> Kind -> m Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Kind -> m Id
mkInternalVar InScopeSet
is0 "field" Kind
ty) [Kind]
fieldTys
  let alt :: Alt
alt = (DataCon -> [TyVar] -> [Id] -> Pat
DataPat DataCon
dc [TyVar]
tvs [Id]
fields, Id -> Term
Var (Id -> Term) -> Id -> Term
forall a b. (a -> b) -> a -> b
$ [Id]
fields [Id] -> Int -> Id
forall a. [a] -> Int -> a
!! Int
index)
  LetBinding -> m LetBinding
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id
nm, Term -> Kind -> [Alt] -> Term
Case (Id -> Term
Var Id
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 pInfo :: PrimInfo
pInfo, _)) = 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 p :: 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)
    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 _])} = Bool
True
  isErr _ = Bool
False

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