{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016-2017, Myrtle Software Ltd,
                    2017-2018, Google Inc.,
                    2021-2022, QBayLogic B.V.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

  Transformations for specialisation.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Clash.Normalize.Transformations.Specialize
  ( appProp
  , constantSpec
  , specialize
  , nonRepSpec
  , typeSpec
  , zeroWidthSpec
  ) where

import Control.Arrow ((***), (&&&))
import Control.DeepSeq (deepseq)
import Control.Exception (throw)
import Control.Lens ((%=))
import qualified Control.Lens as Lens
import qualified Control.Monad as Monad
import Control.Monad.Extra (orM)
import qualified Control.Monad.Writer as Writer (listen)
import Data.Bifunctor (bimap)
import Data.Coerce (coerce)
import qualified Data.Either as Either
import Data.Functor.Const (Const(..))
import qualified Data.Map.Strict as Map
import qualified Data.Monoid as Monoid (getAny)
import qualified Data.Set.Ordered as OSet
import qualified Data.Set.Ordered.Extra as OSet
import qualified Data.Text as Text
import qualified Data.Text.Extra as Text
import GHC.Stack (HasCallStack)

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

import qualified Clash.Sized.Internal.BitVector as BV (BitVector, fromInteger#)
import qualified Clash.Sized.Internal.Index as I (Index, fromInteger#)
import qualified Clash.Sized.Internal.Signed as S (Signed, fromInteger#)
import qualified Clash.Sized.Internal.Unsigned as U (Unsigned, fromInteger#)

import Clash.Core.DataCon (DataCon(dcArgTys))
import Clash.Core.FreeVars (freeLocalVars, termFreeTyVars, typeFreeVars)
import Clash.Core.HasType
import Clash.Core.Literal (Literal(..))
import Clash.Core.Name
  (NameSort(..), Name(..), appendToName, mkUnsafeInternalName, mkUnsafeSystemName)
import Clash.Core.Pretty (showPpr)
import Clash.Core.Subst
import Clash.Core.Term
  ( Term(..), TickInfo, collectArgs, collectArgsTicks, mkApps, mkTmApps, mkTicks, patIds, Bind(..)
  , patVars, mkAbstraction, PrimInfo(..), WorkInfo(..), IsMultiPrim(..), PrimUnfolding(..), stripAllTicks)
import Clash.Core.TermInfo (isLocalVar, isVar, isPolyFun)
import Clash.Core.TyCon (TyConMap, tyConDataCons)
import Clash.Core.Type
  (LitTy(NumTy), Type(LitTy,VarTy), applyFunTy, splitTyConAppM, normalizeType
  , mkPolyFunTy, mkTyConApp)
import Clash.Core.TysPrim
import Clash.Core.Util (listToLets)
import Clash.Core.Var (Var(..), Id, TyVar, mkTyVar)
import Clash.Core.VarEnv
  ( InScopeSet, extendInScopeSet, extendInScopeSetList, lookupVarEnv
  , mkInScopeSet, mkVarSet, unionInScope, elemVarSet)
import Clash.Debug (traceIf, traceM)
import Clash.Driver.Types (Binding(..), TransformationInfo(..), hasTransformationInfo)
import Clash.Netlist.Util (representableType)
import Clash.Rewrite.Combinators (topdownR)
import Clash.Rewrite.Types
  ( TransformContext(..), bindings, censor, curFun, customReprs, extra, tcCache
  , typeTranslator, workFreeBinders, debugOpts, topEntities, specializationLimit)
import Clash.Rewrite.Util
  ( mkBinderFor, mkDerivedName, mkFunction, mkTmBinderFor, setChanged, changed
  , normalizeTermTypes, normalizeId)
import Clash.Rewrite.WorkFree (isWorkFree)
import Clash.Normalize.Types
  ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory)
import Clash.Normalize.Util
  (constantSpecInfo, csrFoundConstant, csrNewBindings, csrNewTerm)
import Clash.Unique
  ( eltsUniqMap, eltsUniqSet, extendUniqMapWith, unitUniqSet, filterUniqMap
  , lookupUniqMap)
import Clash.Util (ClashException(..))

-- | Propagate arguments of application inwards; except for 'Lam' where the
-- argument becomes let-bound. 'appProp' 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.
appProp :: HasCallStack => NormRewrite
appProp ctx@(TransformContext is _) = \case
  e@App {}
    | let (fun,args,ticks) = collectArgsTicks e
    -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks)
          if Monoid.getAny hasChanged
            then return eN
            else return e
  e@TyApp {}
    | let (fun,args,ticks) = collectArgsTicks e
    -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks)
          if Monoid.getAny hasChanged
            then return eN
            else return e
  e          -> return e
 where
  go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo] -> NormalizeSession Term
  go is0 (collectArgsTicks -> (fun,args0@(_:_),ticks0)) args1 ticks1 =
    go is0 fun (args0 ++ args1) (ticks0 ++ ticks1)

  go is0 (Lam v e) (Left arg:args) ticks = do
    setChanged
    bndrs <- Lens.use bindings
    orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case
      True ->
        let subst = extendIdSubst (mkSubst is0) v arg in
        (`mkTicks` ticks) <$> go is0 (substTm "appProp.AppLam" subst e) args []
      False ->
        let is1 = extendInScopeSet is0 v in
        Let (NonRec v arg) <$> go is1 (deShadowTerm is1 e) args ticks

  go is0 (Let (NonRec i x) e) args@(_:_) ticks = do
    setChanged
    let is1 = extendInScopeSet is0 i
    -- XXX: binding should already be deshadowed w.r.t. 'is0'
    Let (NonRec i x) <$> go is1 e args ticks

  go is0 (Let (Rec vs) e) args@(_:_) ticks = do
    setChanged
    let vbs  = map fst vs
        is1  = extendInScopeSetList is0 vbs
    -- XXX: 'vs' should already be deshadowed w.r.t. 'is0'
    Let (Rec vs) <$> go is1 e args ticks

  go is0 (TyLam tv e) (Right t:args) ticks = do
    setChanged
    let subst = extendTvSubst (mkSubst is0) tv t
    (`mkTicks` ticks) <$> go is0 (substTm "appProp.TyAppTyLam" subst e) args []

  go is0 (Case scrut ty0 alts) args0@(_:_) ticks = do
    setChanged
    let isA1 = unionInScope
                 is0
                 ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts)
    (ty1,vs,args1) <- goCaseArg isA1 ty0 [] args0
    case vs of
      [] -> (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is0 args1) alts
      _  -> do
        let vbs   = map fst vs
            is1   = extendInScopeSetList is0 vbs
            alts1 = map (deShadowAlt is1) alts
        -- TODO I should have a mkNonRecLets :: [LetBinding] -> Term -> Term
        -- function which makes a chain of non-recursive let expressions without
        -- needing to first take the SCCs of all the binders.
        listToLets vs . (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is1 args1) alts1

  go is0 (Tick sp e) args ticks = do
    setChanged
    go is0 e args (sp:ticks)

  go _ fun args ticks = return (mkApps (mkTicks fun ticks) args)

  goAlt is0 args0 (p,e) = do
    let (tvs,ids) = patIds p
        is1       = extendInScopeSetList (extendInScopeSetList is0 tvs) ids
    (p,) <$> go is1 e args0 []

  goCaseArg isA ty0 ls0 (Right t:args0) = do
    tcm <- Lens.view tcCache
    let ty1 = piResultTy tcm ty0 t
    (ty2,ls1,args1) <- goCaseArg isA ty1 ls0 args0
    return (ty2,ls1,Right t:args1)

  goCaseArg isA0 ty0 ls0 (Left arg:args0) = do
    tcm <- Lens.view tcCache
    bndrs <- Lens.use bindings
    let argTy = inferCoreTypeOf tcm arg
        ty1   = applyFunTy tcm ty0 argTy
    orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case
      True -> do
        (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0
        return (ty2,ls1,Left arg:args1)
      False -> do
        boundArg <- mkTmBinderFor isA0 tcm (mkDerivedName ctx "app_arg") arg
        let isA1 = extendInScopeSet isA0 boundArg
        (ty2,ls1,args1) <- goCaseArg isA1 ty1 ls0 args0
        return (ty2,(boundArg,arg):ls1,Left (Var boundArg):args1)

  goCaseArg _ ty ls [] = return (ty,ls,[])
{-# SCC appProp #-}

-- | Specialise functions on arguments which are constant, except when they
-- are clock, reset generators.
constantSpec :: HasCallStack => NormRewrite
constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2)
  | (Var {}, args) <- collectArgs e1
  , (_, []) <- Either.partitionEithers args
  , null $ Lens.toListOf termFreeTyVars e2
  = do specInfo<- constantSpecInfo ctx e2
       if csrFoundConstant specInfo then
         let newBindings = csrNewBindings specInfo in
         if null newBindings then
           -- Whole of e2 is constant
           specialize ctx (App e1 e2)
         else do
           -- Parts of e2 are constant
           let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo)
           (body, isSpec) <- Writer.listen $ specialize
             (TransformContext is1 tfCtx)
             (App e1 (csrNewTerm specInfo))

           if Monoid.getAny isSpec
             then changed (listToLets newBindings body)
             else return e
       else
        -- e2 has no constant parts
        return e
constantSpec _ e = return e
{-# SCC constantSpec #-}

-- | Specialize an application on its argument
specialize :: NormRewrite
specialize ctx e = case e of
  (TyApp e1 ty) -> specialize' ctx e (collectArgsTicks e1) (Right ty)
  (App e1 e2)   -> specialize' ctx e (collectArgsTicks e1) (Left  e2)
  _             -> return e

{-
Note [ticks and specialization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As Clash now distinguishes between ticks in expressions when comparing for
alpha equality, this has a knock-on effect when accessing the specialization
cache. Consider these applications which differ only by ticks:

    f[GlobalId] (\x -> ... x[LocalId])
    f[GlobalId] <tick>(\x -> ... x[LocalId])
    f[GlobalId] (\x -> ... <tick>x[LocalId])

If one of these had been specialized, the other two would hit that term in the
specialization cache, saving Clash from having to re-do work which is in effect
the same. To preserve this behaviour, we use 'stripAllTicks' on the keys for
the specialization cache.

TODO While this preserves the old behaviour, the old behaviour is likely not
quite what we want. Using a value from the specialization cache may change the
ticks present, which can affect naming / debugging information in generated HDL.
We may also not want to look at ticks, as then the specialization cache will
miss on virtually every lookup which could add to normalization time.
-}

-- | Specialize an application on its argument
specialize'
  :: TransformContext
  -- ^ Transformation context
  -> Term
  -- ^ Original term
  -> (Term, [Either Term Type], [TickInfo])
  -- ^ Function part of the term, split into root and applied arguments
  -> Either Term Type
  -- ^ Argument to specialize on
  -> NormalizeSession Term
specialize' (TransformContext is0 _) e (Var f, args, ticks) specArgIn = do
  opts <- Lens.view debugOpts
  tcm <- Lens.view tcCache

  -- Don't specialize TopEntities
  topEnts <- Lens.view topEntities
  if f `elemVarSet` topEnts
  then do
    case specArgIn of
      Left _ -> do
        traceM ("Not specializing TopEntity: " ++ showPpr (varName f))
        return e
      Right tyArg ->
        traceIf (hasTransformationInfo AppliedTerm opts) ("Dropping type application on TopEntity: " ++ showPpr (varName f) ++ "\ntype:\n" ++ showPpr tyArg) $
        -- TopEntities aren't allowed to be semantically polymorphic.
        -- But using type equality constraints they may be syntactically polymorphic.
        -- > topEntity :: forall dom . (dom ~ "System") => Signal dom Bool -> Signal dom Bool
        -- The TyLam's in the body will have been removed by 'Clash.Normalize.Util.substWithTyEq'.
        -- So we drop the TyApp ("specializing" on it) and change the varType to match.
        let newVarTy = piResultTy tcm (coreTypeOf f) tyArg
        in  changed (mkApps (mkTicks (Var f{varType = newVarTy}) ticks) args)
  else do -- NondecreasingIndentation

  let specArg = bimap (normalizeTermTypes tcm) (normalizeType tcm) specArgIn
      -- Create binders and variable references for free variables in 'specArg'
      -- (specBndrsIn,specVars) :: ([Either Id TyVar], [Either Term Type])
      (specBndrsIn,specVars) = specArgBndrsAndVars specArg
      argLen  = length args
      specBndrs :: [Either Id TyVar]
      specBndrs = map (Lens.over Lens._Left (normalizeId tcm)) specBndrsIn

      -- See Note [ticks and specialization]
      specAbs :: Either Term Type
      specAbs = either (Left . stripAllTicks . (`mkAbstraction` specBndrs)) (Right . id) specArg
  -- Determine if 'f' has already been specialized on (a type-normalized) 'specArg'
  specM <- Map.lookup (f,argLen,specAbs) <$> Lens.use (extra.specialisationCache)
  case specM of
    -- Use previously specialized function
    Just f' ->
      traceIf (hasTransformationInfo AppliedTerm opts)
        ("Using previous specialization of " ++ showPpr (varName f) ++ " on " ++
          (either showPpr showPpr) specAbs ++ ": " ++ showPpr (varName f')) $
        changed $ mkApps (mkTicks (Var f') ticks) (args ++ specVars)
    -- Create new specialized function
    Nothing -> do
      -- Determine if we can specialize f
      bodyMaybe <- fmap (lookupUniqMap (varName f)) $ Lens.use bindings
      case bodyMaybe of
        Just (Binding _ sp inl _ bodyTm _) -> do
          -- Determine if we see a sequence of specializations on a growing argument
          specHistM <- lookupUniqMap f <$> Lens.use (extra.specialisationHistory)
          specLim   <- Lens.view specializationLimit
          if maybe False (> specLim) specHistM
            then throw (ClashException
                        sp
                        (unlines [ "Hit specialization limit " ++ show specLim ++ " on function `" ++ showPpr (varName f) ++ "'.\n"
                                 , "The function `" ++ showPpr f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"
                                 , "Body of `" ++ showPpr f ++ "':\n" ++ showPpr bodyTm ++ "\n"
                                 , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showPpr showPpr) specArg
                                 , "Run with '-fclash-spec-limit=N' to increase the specialization limit to N."
                                 ])
                        Nothing)
            else do
              let existingNames = collectBndrsMinusApps bodyTm
                  newNames      = [ mkUnsafeInternalName ("pTS" `Text.append` Text.pack (show n)) n
                                  | n <- [(0::Int)..]
                                  ]
              -- Make new binders for existing arguments
              (boundArgs,argVars) <- fmap (unzip . map (either (Left &&& Left . Var) (Right &&& Right . VarTy))) $
                                     Monad.zipWithM
                                       (mkBinderFor is0 tcm)
                                       (existingNames ++ newNames)
                                       args
              -- Determine name the resulting specialized function, and the
              -- form of the specialized-on argument
              (fId,inl',specArg') <- case specArg of
                Left a@(collectArgsTicks -> (Var g,gArgs,_gTicks)) -> if isPolyFun tcm a
                    then do
                      -- In case we are specialising on an argument that is a
                      -- global function then we use that function's name as the
                      -- name of the specialized higher-order function.
                      -- Additionally, we will return the body of the global
                      -- function, instead of a variable reference to the
                      -- global function.
                      --
                      -- This will turn things like @mealy g k@ into a new
                      -- binding @g'@ where both the body of @mealy@ and @g@
                      -- are inlined, meaning the state-transition-function
                      -- and the memory element will be in a single function.
                      gTmM <- fmap (lookupUniqMap (varName g)) $ Lens.use bindings
                      return (g,maybe inl bindingSpec gTmM, maybe specArg (Left . (`mkApps` gArgs) . bindingTerm) gTmM)
                    else return (f,inl,specArg)
                _ -> return (f,inl,specArg)
              -- Create specialized functions
              let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg'])) (boundArgs ++ specBndrs)
              newf <- mkFunction (varName fId) sp inl' newBody
              -- Remember specialization
              (extra.specialisationHistory) %= extendUniqMapWith f 1 (+)
              (extra.specialisationCache)  %= Map.insert (f,argLen,specAbs) newf
              -- use specialized function
              let newExpr = mkApps (mkTicks (Var newf) ticks) (args ++ specVars)
              newf `deepseq` changed newExpr
        Nothing -> return e
  where
    collectBndrsMinusApps :: Term -> [Name a]
    collectBndrsMinusApps = reverse . go []
      where
        go bs (Lam v e')    = go (coerce (varName v):bs)  e'
        go bs (TyLam tv e') = go (coerce (varName tv):bs) e'
        go bs (App e' _) = case go [] e' of
          []  -> bs
          bs' -> init bs' ++ bs
        go bs (TyApp e' _) = case go [] e' of
          []  -> bs
          bs' -> init bs' ++ bs
        go bs _ = bs

-- Specialising non Var's is used by nonRepANF
specialize' _ctx _ (appE,args,ticks) (Left specArg) = do
  -- Create binders and variable references for free variables in 'specArg'
  let (specBndrs,specVars) = specArgBndrsAndVars (Left specArg)
  -- Create specialized function
      newBody = mkAbstraction specArg specBndrs
  -- See if there's an existing binder that's alpha-equivalent to the
  -- specialized function
  existing <- filterUniqMap ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings
  -- Create a new function if an alpha-equivalent binder doesn't exist
  newf <- case eltsUniqMap existing of
    [] -> do (cf,sp) <- Lens.use curFun
             mkFunction (appendToName (varName cf) "_specF") sp NoUserInline newBody
    (b:_) -> return (bindingId b)
  -- Create specialized argument
  let newArg  = Left $ mkApps (Var newf) specVars
  -- Use specialized argument
  let newExpr = mkApps (mkTicks appE ticks) (args ++ [newArg])
  changed newExpr

specialize' _ e _ _ = return e

-- Note [Collect free-variables in an insertion-ordered set]
--
-- In order for the specialization cache to work, 'specArgBndrsAndVars' should
-- yield (alpha equivalent) results for the same specialization. While collecting
-- free variables in a given term or type it should therefore keep a stable
-- ordering based on the order in which it finds free vars. To see why,
-- consider the following two pseudo-code calls to 'specialise':
--
--     specialise {f ('a', x[123], y[456])}
--     specialise {f ('b', x[456], y[123])}
--
-- Collecting the binders in a VarSet would yield the following (unique ordered)
-- sets:
--
--     {x[123], y[456]}
--     {y[123], x[456]}
--
-- ..and therefore breaking specializing caching. We now track them in insert-
-- ordered sets, yielding:
--
--     {x[123], y[456]}
--     {x[456], y[123]}
--

-- | Create binders and variable references for free variables in 'specArg'
specArgBndrsAndVars
  :: Either Term Type
  -> ([Either Id TyVar], [Either Term Type])
specArgBndrsAndVars specArg =
  -- See Note [Collect free-variables in an insertion-ordered set]
  let unitFV :: Var a -> Const (OSet.OLSet TyVar, OSet.OLSet Id) (Var a)
      unitFV v@(Id {}) = Const (mempty, coerce (OSet.singleton (coerce v)))
      unitFV v@(TyVar {}) = Const (coerce (OSet.singleton (coerce v)), mempty)

      (specFTVs,specFVs) = case specArg of
        Left tm  -> (OSet.toListL *** OSet.toListL) . getConst $
                    Lens.foldMapOf freeLocalVars unitFV tm
        Right ty -> (eltsUniqSet (Lens.foldMapOf typeFreeVars unitUniqSet ty),[] :: [Id])

      specTyBndrs = map Right specFTVs
      specTmBndrs = map Left  specFVs

      specTyVars  = map (Right . VarTy) specFTVs
      specTmVars  = map (Left . Var) specFVs

  in  (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)

-- | Specialize functions on their non-representable argument
nonRepSpec :: HasCallStack => NormRewrite
nonRepSpec ctx e@(App e1 e2)
  | (Var {}, args) <- collectArgs e1
  , (_, [])     <- Either.partitionEithers args
  , null $ Lens.toListOf termFreeTyVars e2
  = do tcm <- Lens.view tcCache
       let e2Ty = inferCoreTypeOf tcm e2
       let localVar = isLocalVar e2
       nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator
                                              <*> Lens.view customReprs
                                              <*> pure False
                                              <*> Lens.view tcCache
                                              <*> pure e2Ty)
       if nonRepE2 && not localVar
         then do
           e2' <- inlineInternalSpecialisationArgument e2
           specialize ctx (App e1 e2')
         else return 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 app
      | (Var f,fArgs,ticks) <- collectArgsTicks app
      = do
        fTmM <- lookupVarEnv f <$> Lens.use bindings
        case fTmM of
          Just b
            | nameSort (varName (bindingId b)) == Internal
            -> censor (const mempty)
                      (topdownR appProp ctx
                        (mkApps (mkTicks (bindingTerm b) ticks) fArgs))
          _ -> return app
      | otherwise = return app

nonRepSpec _ e = return e
{-# SCC nonRepSpec #-}

-- | Specialize functions on their type
typeSpec :: HasCallStack => NormRewrite
typeSpec ctx e@(TyApp e1 ty)
  | (Var {},  args) <- collectArgs e1
  , null $ Lens.toListOf typeFreeVars ty
  , (_, []) <- Either.partitionEithers args
  = specialize ctx e

typeSpec _ e = return e
{-# SCC typeSpec #-}

-- | Specialize functions on arguments which are zero-width. These arguments
-- can have only one possible value, and specialising on this value may create
-- additional oppourtunities for transformations to fire.
--
-- As we can't remove zero-width arguements (as transformations cannot change
-- the type of a term), we instead substitute all occurances of a lambda-bound
-- variable with a zero-width type with the only value of that type.
--
zeroWidthSpec :: HasCallStack => NormRewrite
zeroWidthSpec (TransformContext is _) e@(Lam i x0) = do
  tcm <- Lens.view tcCache
  let bndrTy = normalizeType tcm (coreTypeOf i)

  case zeroWidthTypeElem tcm bndrTy of
    Just tm ->
      let subst = extendIdSubst (mkSubst is) i tm
          x1 = substTm "zeroWidthSpec" subst x0
       in changed (Lam i x1)

    Nothing ->
      return e

zeroWidthSpec _ e = return e
{-# SCC zeroWidthSpec #-}

-- Get the only element of a type, if it is zero-width.
--
zeroWidthTypeElem :: TyConMap -> Type -> Maybe Term
zeroWidthTypeElem tcm ty = do
  (tcNm, args) <- splitTyConAppM ty

  if | nameOcc tcNm == Text.showt ''BV.BitVector
     , [LitTy (NumTy 0)] <- args
     -> return (bitVectorZW tcNm args)

     | nameOcc tcNm == Text.showt ''I.Index
     , [LitTy (NumTy 1)] <- args
     -> return (indexZW tcNm args)

     | nameOcc tcNm == Text.showt ''S.Signed
     , [LitTy (NumTy 0)] <- args
     -> return (signedZW tcNm args)

     | nameOcc tcNm == Text.showt ''U.Unsigned
     , [LitTy (NumTy 0)] <- args
     -> return (unsignedZW tcNm args)

     -- Any other zero-width type should only have a single data constructor
     -- where all fields are also zero-width.
     | otherwise
     -> do
       tc <- lookupUniqMap tcNm tcm

       case tyConDataCons tc of
         [dc] -> do
           zwArgs <- traverse (zeroWidthTypeElem tcm) (dcArgTys dc)
           return (mkTmApps (Data dc) zwArgs)

         _ ->
           Nothing
 where
  nNm = mkUnsafeSystemName "n" 0
  nTv = mkTyVar typeNatKind nNm

  mkBitVector tcNm =
    let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv])
                 [Left nTv, Right naturalPrimTy, Right naturalPrimTy, Right integerPrimTy]
     in PrimInfo (Text.showt 'BV.fromInteger#) prTy WorkNever SingleResult NoUnfolding

  bitVectorZW tcNm tyArgs =
    let pr = mkBitVector tcNm
     in mkApps (Prim pr) $ fmap Right tyArgs <>
          [ Left (Literal (NaturalLiteral 0))
          , Left (Literal (NaturalLiteral 0))
          , Left (Literal (IntegerLiteral 0))
          ]

  mkSizedNum tcNm n =
    let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv])
                 [Left nTv, Right naturalPrimTy, Right integerPrimTy]
     in PrimInfo n prTy WorkNever SingleResult NoUnfolding

  indexZW tcNm tyArgs =
    let pr = mkSizedNum tcNm (Text.showt 'I.fromInteger#)
     in mkApps (Prim pr) $ fmap Right tyArgs <>
          [ Left (Literal (NaturalLiteral 1))
          , Left (Literal (IntegerLiteral 0))
          ]

  signedZW tcNm tyArgs =
    let pr = mkSizedNum tcNm (Text.showt 'S.fromInteger#)
     in mkApps (Prim pr) $ fmap Right tyArgs <>
          [ Left (Literal (NaturalLiteral 0))
          , Left (Literal (IntegerLiteral 0))
          ]

  unsignedZW tcNm tyArgs =
    let pr = mkSizedNum tcNm (Text.showt 'U.fromInteger#)
     in mkApps (Prim pr) $ fmap Right tyArgs <>
          [ Left (Literal (NaturalLiteral 0))
          , Left (Literal (IntegerLiteral 0))
          ]
