vectorise: Put it out of its misery

Poor DPH and its vectoriser have long been languishing; sadly it seems there is
little chance that the effort will be rekindled. Every few years we discuss
what to do with this mass of code and at least once we have agreed that it
should be archived on a branch and removed from `master`. Here we do just that,
eliminating heaps of dead code in the process.

Here we drop the ParallelArrays extension, the vectoriser, and the `vector` and
`primitive` submodules.

Test Plan: Validate

Reviewers: simonpj, simonmar, hvr, goldfire, alanz

Reviewed By: simonmar

Subscribers: goldfire, rwbarton, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4761

5 files changed, 0 insertions, 800 deletions

diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
deleted file mode 100644
index eb648710a9..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ /dev/null
@@ -1,245 +0,0 @@
--- |The Vectorisation monad.
-
-module Vectorise.Monad.Base (
-  -- * The Vectorisation Monad
-  VResult(..),
-  VM(..),
-
-  -- * Lifting
-  liftDs,
-
-  -- * Error Handling
-  cantVectorise,
-  maybeCantVectorise,
-  maybeCantVectoriseM,
-
-  -- * Debugging
-  emitVt, traceVt, dumpOptVt, dumpVt,
-
-  -- * Control
-  noV, traceNoV,
-  ensureV, traceEnsureV,
-  onlyIfV,
-  tryV, tryErrV,
-  maybeV,  traceMaybeV,
-  orElseV, orElseErrV,
-  fixV,
-) where
-
-import GhcPrelude
-
-import Vectorise.Builtins
-import Vectorise.Env
-
-import DsMonad
-import TcRnMonad
-import ErrUtils
-import Outputable
-import DynFlags
-
-import Control.Monad
-
-
--- The Vectorisation Monad ----------------------------------------------------
-
--- |Vectorisation can either succeed with new envionment and a value, or return with failure
--- (including a description of the reason for failure).
---
-data VResult a
-  = Yes GlobalEnv LocalEnv a
-  | No  SDoc
-
-newtype VM a
-  = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
-
-instance Monad VM where
-  VM p >>= f = VM $ \bi genv lenv -> do
-                                       r <- p bi genv lenv
-                                       case r of
-                                         Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
-                                         No reason         -> return $ No reason
-
-instance Applicative VM where
-  pure x = VM $ \_ genv lenv -> return (Yes genv lenv x)
-  (<*>) = ap
-
-instance Functor VM where
-  fmap = liftM
-
-instance MonadIO VM where
-  liftIO = liftDs . liftIO
-
-instance HasDynFlags VM where
-    getDynFlags = liftDs getDynFlags
-
--- Lifting --------------------------------------------------------------------
-
--- |Lift a desugaring computation into the vectorisation monad.
---
-liftDs :: DsM a -> VM a
-liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
-
-
--- Error Handling -------------------------------------------------------------
-
--- |Throw a `pgmError` saying we can't vectorise something.
---
-cantVectorise :: DynFlags -> String -> SDoc -> a
-cantVectorise dflags s d = pgmError
-                  . showSDoc dflags
-                  $ vcat [text "*** Vectorisation error ***",
-                          nest 4 $ sep [text s, nest 4 d]]
-
--- |Like `fromJust`, but `pgmError` on Nothing.
---
-maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a
-maybeCantVectorise dflags s d Nothing  = cantVectorise dflags s d
-maybeCantVectorise _ _ _ (Just x) = x
-
--- |Like `maybeCantVectorise` but in a `Monad`.
---
-maybeCantVectoriseM :: (Monad m, HasDynFlags m)
-                    => String -> SDoc -> m (Maybe a) -> m a
-maybeCantVectoriseM s d p
-  = do
-      r <- p
-      case r of
-        Just x  -> return x
-        Nothing ->
-            do dflags <- getDynFlags
-               cantVectorise dflags s d
-
-
--- Debugging ------------------------------------------------------------------
-
--- |Output a trace message if -ddump-vt-trace is active.
---
-emitVt :: String -> SDoc -> VM ()
-emitVt herald doc
-  = liftDs $ do
-      dflags <- getDynFlags
-      liftIO . printOutputForUser dflags alwaysQualify $
-        hang (text herald) 2 doc
-
--- |Output a trace message if -ddump-vt-trace is active.
---
-traceVt :: String -> SDoc -> VM ()
-traceVt herald doc
-  = liftDs $ traceOptIf Opt_D_dump_vt_trace $ hang (text herald) 2 doc
-
--- |Dump the given program conditionally.
---
-dumpOptVt :: DumpFlag -> String -> SDoc -> VM ()
-dumpOptVt flag header doc
-  = do { b <- liftDs $ doptM flag
-       ; if b
-         then dumpVt header doc
-         else return ()
-       }
-
--- |Dump the given program unconditionally.
---
-dumpVt :: String -> SDoc -> VM ()
-dumpVt header doc
-  = do { unqual <- liftDs mkPrintUnqualifiedDs
-       ; dflags <- liftDs getDynFlags
-       ; liftIO $ printOutputForUser dflags unqual (mkDumpDoc header doc)
-       }
-
-
--- Control --------------------------------------------------------------------
-
--- |Return some result saying we've failed.
---
-noV :: SDoc -> VM a
-noV reason = VM $ \_ _ _ -> return $ No reason
-
--- |Like `traceNoV` but also emit some trace message to stderr.
---
-traceNoV :: String -> SDoc -> VM a
-traceNoV s d = pprTrace s d $ noV d
-
--- |If `True` then carry on, otherwise fail.
---
-ensureV :: SDoc -> Bool -> VM ()
-ensureV reason  False = noV reason
-ensureV _reason True  = return ()
-
--- |Like `ensureV` but if we fail then emit some trace message to stderr.
---
-traceEnsureV :: String -> SDoc -> Bool -> VM ()
-traceEnsureV s d False = traceNoV s d
-traceEnsureV _ _ True  = return ()
-
--- |If `True` then return the first argument, otherwise fail.
---
-onlyIfV :: SDoc -> Bool -> VM a -> VM a
-onlyIfV reason b p = ensureV reason b >> p
-
--- |Try some vectorisation computaton.
---
--- If it succeeds then return `Just` the result; otherwise, return `Nothing` after emitting a
--- failure message.
---
-tryErrV :: VM a -> VM (Maybe a)
-tryErrV (VM p) = VM $ \bi genv lenv ->
-  do
-    r <- p bi genv lenv
-    case r of
-      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
-      No reason         -> do { unqual <- mkPrintUnqualifiedDs
-                              ; dflags <- getDynFlags
-                              ; liftIO $
-                                  printInfoForUser dflags unqual $
-                                    text "Warning: vectorisation failure:" <+> reason
-                              ; return (Yes genv  lenv  Nothing)
-                              }
-
--- |Try some vectorisation computaton.
---
--- If it succeeds then return `Just` the result; otherwise, return `Nothing` without emitting a
--- failure message.
---
-tryV :: VM a -> VM (Maybe a)
-tryV (VM p) = VM $ \bi genv lenv ->
-  do
-    r <- p bi genv lenv
-    case r of
-      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
-      No _reason        -> return (Yes genv  lenv  Nothing)
-
--- |If `Just` then return the value, otherwise fail.
---
-maybeV :: SDoc -> VM (Maybe a) -> VM a
-maybeV reason p = maybe (noV reason) return =<< p
-
--- |Like `maybeV` but emit a message to stderr if we fail.
---
-traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
-traceMaybeV s d p = maybe (traceNoV s d) return =<< p
-
--- |Try the first computation,
---
---   * if it succeeds then take the returned value,
---   * if it fails then run the second computation instead while emitting a failure message.
---
-orElseErrV :: VM a -> VM a -> VM a
-orElseErrV p q = maybe q return =<< tryErrV p
-
--- |Try the first computation,
---
---   * if it succeeds then take the returned value,
---   * if it fails then run the second computation instead without emitting a failure message.
---
-orElseV :: VM a -> VM a -> VM a
-orElseV p q = maybe q return =<< tryV p
-
--- |Fixpoint in the vectorisation monad.
---
-fixV :: (a -> VM a) -> VM a
-fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
-  where
-    -- NOTE: It is essential that we are lazy in r above so do not replace
-    --       calls to this function by an explicit case.
-    unYes (Yes _ _ x) = x
-    unYes (No reason) = pprPanic "Vectorise.Monad.Base.fixV: no result" reason
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
deleted file mode 100644
index 9abeb59dcb..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ /dev/null
@@ -1,239 +0,0 @@
--- Operations on the global state of the vectorisation monad.
-
-module Vectorise.Monad.Global (
-  readGEnv,
-  setGEnv,
-  updGEnv,
-
-  -- * Configuration
-  isVectAvoidanceAggressive,
-
-  -- * Vars
-  defGlobalVar, undefGlobalVar,
-
-  -- * Vectorisation declarations
-  lookupVectDecl,
-
-  -- * Scalars
-  globalParallelVars, globalParallelTyCons,
-
-  -- * TyCons
-  lookupTyCon,
-  defTyConName, defTyCon, globalVectTyCons,
-
-  -- * Datacons
-  lookupDataCon,
-  defDataCon,
-
-  -- * PA Dictionaries
-  lookupTyConPA,
-  defTyConPAs,
-
-  -- * PR Dictionaries
-  lookupTyConPR
-) where
-
-import GhcPrelude
-
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import CoreSyn
-import Type
-import TyCon
-import DataCon
-import DynFlags
-import NameEnv
-import NameSet
-import Name
-import VarEnv
-import VarSet
-import Var as Var
-import Outputable
-
-
--- Global Environment ---------------------------------------------------------
-
--- |Project something from the global environment.
---
-readGEnv :: (GlobalEnv -> a) -> VM a
-readGEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
-
--- |Set the value of the global environment.
---
-setGEnv :: GlobalEnv -> VM ()
-setGEnv genv  = VM $ \_ _ lenv -> return (Yes genv lenv ())
-
--- |Update the global environment using the provided function.
---
-updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
-updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
-
-
--- Configuration --------------------------------------------------------------
-
--- |Should we avoid as much vectorisation as possible?
---
--- Set by '-f[no]-vectorisation-avoidance'
---
-isVectAvoidanceAggressive :: VM Bool
-isVectAvoidanceAggressive = readGEnv global_vect_avoid
-
-
--- Vars -----------------------------------------------------------------------
-
--- |Add a mapping between a global var and its vectorised version to the state.
---
-defGlobalVar :: Var -> Var -> VM ()
-defGlobalVar v v'
-  = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v')
-
-           -- check for duplicate vectorisation
-       ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
-       ; case currentDef of
-           Just old_v' ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Variable is already vectorised:" $
-                            ppr v <+> moduleOf v old_v'
-           Nothing     -> return ()
-
-       ; updGEnv  $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
-       }
-  where
-    moduleOf var var' | var == var'
-                      = text "vectorises to itself"
-                      | Just mod <- nameModule_maybe (Var.varName var')
-                      = text "in module" <+> ppr mod
-                      | otherwise
-                      = text "in the current module"
-
--- |Remove the mapping of a variable in the vectorisation map.
---
-undefGlobalVar :: Var -> VM ()
-undefGlobalVar v
-  = do
-    { traceVt "REMOVING global var mapping:" (ppr v)
-    ; updGEnv  $ \env -> env { global_vars = delVarEnv (global_vars env) v }
-    }
-
-
--- Vectorisation declarations -------------------------------------------------
-
--- |Check whether a variable has a vectorisation declaration.
---
--- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration.
--- The second component contains the given type and expression in case of a 'VECTORISE' declaration.
---
-lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr))
-lookupVectDecl var
-  = readGEnv $ \env ->
-      case lookupVarEnv (global_vect_decls env) var of
-        Nothing -> (False, Nothing)
-        Just Nothing  -> (True, Nothing)
-        Just vectDecl -> (False, vectDecl)
-
-
--- Parallel entities -----------------------------------------------------------
-
--- |Get the set of global parallel variables.
---
-globalParallelVars :: VM DVarSet
-globalParallelVars = readGEnv global_parallel_vars
-
--- |Get the set of all parallel type constructors (those that may embed parallelism) including both
--- both those parallel type constructors declared in an imported module and those declared in the
--- current module.
---
-globalParallelTyCons :: VM NameSet
-globalParallelTyCons = readGEnv global_parallel_tycons
-
-
--- TyCons ---------------------------------------------------------------------
-
--- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment
--- contains a vectorised version if the original `TyCon` embeds any parallel arrays.
---
-lookupTyCon :: TyCon -> VM (Maybe TyCon)
-lookupTyCon tc
-  = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-
--- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
---
--- The second argument is only to enable tracing for (mutually) recursively defined type
--- constructors, where we /must not/ pull at the vectorised type constructors (because that would
--- pull too early at the recursive knot).
---
-defTyConName :: TyCon -> Name -> TyCon -> VM ()
-defTyConName tc nameOfTc' tc'
-  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc')
-
-           -- check for duplicate vectorisation
-       ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-       ; case currentDef of
-           Just old_tc' ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Type constructor or class is already vectorised:" $
-                            ppr tc <+> moduleOf tc old_tc'
-           Nothing     -> return ()
-
-       ; updGEnv $ \env ->
-           env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
-       }
-  where
-    moduleOf tc tc' | tc == tc'
-                    = text "vectorises to itself"
-                    | Just mod <- nameModule_maybe (tyConName tc')
-                    = text "in module" <+> ppr mod
-                    | otherwise
-                    = text "in the current module"
-
--- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
---
-defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc' = defTyConName tc (tyConName tc') tc'
-
--- |Get the set of all vectorised type constructors.
---
-globalVectTyCons :: VM (NameEnv TyCon)
-globalVectTyCons = readGEnv global_tycons
-
-
--- DataCons -------------------------------------------------------------------
-
--- |Lookup the vectorised version of a `DataCon` from the global environment.
---
-lookupDataCon :: DataCon -> VM (Maybe DataCon)
-lookupDataCon dc
-  | isTupleTyCon (dataConTyCon dc)
-  = return (Just dc)
-  | otherwise
-  = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
-
--- |Add the mapping between plain and vectorised `DataCon`s to the global environment.
---
-defDataCon :: DataCon -> DataCon -> VM ()
-defDataCon dc dc' = updGEnv $ \env ->
-  env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
-
-
--- 'PA' dictionaries ------------------------------------------------------------
-
--- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment.
---
-lookupTyConPA :: TyCon -> VM (Maybe Var)
-lookupTyConPA tc
-  = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
-
--- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global
--- environment.
---
-defTyConPAs :: [(TyCon, Var)] -> VM ()
-defTyConPAs ps = updGEnv $ \env ->
-  env { global_pa_funs = extendNameEnvList (global_pa_funs env)
-                                           [(tyConName tc, pa) | (tc, pa) <- ps] }
-
-
--- PR Dictionaries ------------------------------------------------------------
-
-lookupTyConPR :: TyCon -> VM (Maybe Var)
-lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
deleted file mode 100644
index 68d70a46b6..0000000000
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Vectorise.Monad.InstEnv
-  ( existsInst
-  , lookupInst
-  , lookupFamInst
-  )
-where
-
-import GhcPrelude
-
-import Vectorise.Monad.Global
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import DynFlags
-import FamInstEnv
-import InstEnv
-import Class
-import Type
-import TyCon
-import Outputable
-import Util
-
-
-#include "HsVersions.h"
-
-
--- Check whether a unique class instance for a given class and type arguments exists.
---
-existsInst :: Class -> [Type] -> VM Bool
-existsInst cls tys
-  = do { instEnv <- readGEnv global_inst_env
-       ; return $ either (const False) (const True) (lookupUniqueInstEnv instEnv cls tys)
-       }
-
--- Look up the dfun of a class instance.
---
--- The match must be unique —i.e., match exactly one instance— but the
--- type arguments used for matching may be more specific than those of
--- the class instance declaration.  The found class instances must not have
--- any type variables in the instance context that do not appear in the
--- instances head (i.e., no flexi vars); for details for what this means,
--- see the docs at InstEnv.lookupInstEnv.
---
-lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
-lookupInst cls tys
-  = do { instEnv <- readGEnv global_inst_env
-       ; case lookupUniqueInstEnv instEnv cls tys of
-           Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys)
-           Left  err              ->
-               do dflags <- getDynFlags
-                  cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err
-       }
-
--- Look up a family instance.
---
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the family instance declaration.
---
--- Return the family instance and its type instance.  For example, if we have
---
---  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
---
--- then we have a coercion (ie, type instance of family instance coercion)
---
---  :Co:R42T Int :: T [Int] ~ :R42T Int
---
--- which implies that :R42T was declared as 'data instance T [a]'.
---
-lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch
-lookupFamInst tycon tys
-  = ASSERT( isOpenFamilyTyCon tycon )
-    do { instEnv <- readGEnv global_fam_inst_env
-       ; case lookupFamInstEnv instEnv tycon tys of
-           [match] -> return match
-           _other                ->
-             do dflags <- getDynFlags
-                cantVectorise dflags "Vectorise.Monad.InstEnv.lookupFamInst: not found: "
-                           (ppr $ mkTyConApp tycon tys)
-       }
diff --git a/compiler/vectorise/Vectorise/Monad/Local.hs b/compiler/vectorise/Vectorise/Monad/Local.hs
deleted file mode 100644
index 1f0da7ebd2..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Local.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-module Vectorise.Monad.Local
-  ( readLEnv
-  , setLEnv
-  , updLEnv
-  , localV
-  , closedV
-  , getBindName
-  , inBind
-  , lookupTyVarPA
-  , defLocalTyVar
-  , defLocalTyVarWithPA
-  , localTyVars
-  )
-where
-
-import GhcPrelude
-
-import Vectorise.Monad.Base
-import Vectorise.Env
-
-import CoreSyn
-import Name
-import VarEnv
-import Var
-import FastString
-
--- Local Environment ----------------------------------------------------------
-
--- |Project something from the local environment.
---
-readLEnv :: (LocalEnv -> a) -> VM a
-readLEnv f  = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
-
--- |Set the local environment.
---
-setLEnv :: LocalEnv -> VM ()
-setLEnv lenv  = VM $ \_ genv _ -> return (Yes genv lenv ())
-
--- |Update the environment using the provided function.
---
-updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
-updLEnv f  = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
-
--- |Perform a computation in its own local environment.
--- This does not alter the environment of the current state.
---
-localV :: VM a -> VM a
-localV p
-  = do
-    { env <- readLEnv id
-    ; x   <- p
-    ; setLEnv env
-    ; return x
-    }
-
--- |Perform a computation in an empty local environment.
---
-closedV :: VM a -> VM a
-closedV p
-  = do
-    { env <- readLEnv id
-    ; setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
-    ; x   <- p
-    ; setLEnv env
-    ; return x
-    }
-
--- |Get the name of the local binding currently being vectorised.
---
-getBindName :: VM FastString
-getBindName = readLEnv local_bind_name
-
--- |Run a vectorisation computation in a local environment,
--- with this id set as the current binding.
---
-inBind :: Id -> VM a -> VM a
-inBind id p
-  = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
-       p
-
--- |Lookup a PA tyvars from the local environment.
-lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
-lookupTyVarPA tv
-   = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
-
--- |Add a tyvar to the local environment.
-defLocalTyVar :: TyVar -> VM ()
-defLocalTyVar tv = updLEnv $ \env ->
-  env { local_tyvars   = tv : local_tyvars env
-      , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
-      }
-
--- |Add mapping between a tyvar and pa dictionary to the local environment.
-defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
-defLocalTyVarWithPA tv pa = updLEnv $ \env ->
-  env { local_tyvars   = tv : local_tyvars env
-      , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
-      }
-
--- |Get the set of tyvars from the local environment.
-localTyVars :: VM [TyVar]
-localTyVars = readLEnv (reverse . local_tyvars)
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
deleted file mode 100644
index b1a8cb4092..0000000000
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ /dev/null
@@ -1,132 +0,0 @@
--- |Computations in the vectorisation monad concerned with naming and fresh variable generation.
-
-module Vectorise.Monad.Naming
-  ( mkLocalisedName
-  , mkDerivedName
-  , mkVectId
-  , cloneVar
-  , newExportedVar
-  , newLocalVar
-  , newLocalVars
-  , newDummyVar
-  , newTyVar
-  , newCoVar
-  )
-where
-
-import GhcPrelude
-
-import Vectorise.Monad.Base
-
-import DsMonad
-import TcType
-import Type
-import Var
-import Module
-import Name
-import SrcLoc
-import MkId
-import Id
-import IdInfo( IdDetails(VanillaId) )
-import FastString
-
-import Control.Monad
-
-
--- Naming ---------------------------------------------------------------------
-
--- |Create a localised variant of a name, using the provided function to transform its `OccName`.
---
--- If the name external, encode the original name's module into the new 'OccName'.  The result is
--- always an internal system name.
---
-mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
-mkLocalisedName mk_occ name
-  = do { mod <- liftDs getModule
-       ; u   <- liftDs newUnique
-       ; let occ_name = mkLocalisedOccName mod mk_occ name
-
-             new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
-                      | otherwise           = mkSystemName   u     occ_name
-
-       ; return new_name }
-
-mkDerivedName :: (OccName -> OccName) -> Name -> VM Name
--- Similar to mkLocalisedName, but assumes the
--- incoming name is from this module.
--- Works on External names only
-mkDerivedName mk_occ name
-  = do { u   <- liftDs newUnique
-       ; return (mkExternalName u (nameModule name)
-                                  (mk_occ (nameOccName name))
-                                  (nameSrcSpan name)) }
-
--- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that
--- vectorised dfun ids must be dfuns again.
---
--- Force the new name to be a system name and, if the original was an external name, disambiguate
--- the new name with the module name of the original.
---
-mkVectId :: Id -> Type -> VM Id
-mkVectId id ty
-  = do { name <- mkLocalisedName mkVectOcc (getName id)
-       ; let id' | isDFunId id     = MkId.mkDictFunId name tvs theta cls tys
-                 | isExportedId id = Id.mkExportedLocalId VanillaId name ty
-                 | otherwise       = Id.mkLocalIdOrCoVar name ty
-       ; return id'
-       }
-  where
-    -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys
-    -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary
-    --     functions are always fully applied.
-    (tvs, theta, pty) = tcSplitSigmaTy  ty
-    (cls, tys)        = tcSplitDFunHead pty
-
--- |Make a fresh instance of this var, with a new unique.
---
-cloneVar :: Var -> VM Var
-cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
-
--- |Make a fresh exported variable with the given type.
---
-newExportedVar :: OccName -> Type -> VM Var
-newExportedVar occ_name ty
- = do mod <- liftDs getModule
-      u   <- liftDs newUnique
-
-      let name = mkExternalName u mod occ_name noSrcSpan
-
-      return $ Id.mkExportedLocalId VanillaId name ty
-
--- |Make a fresh local variable with the given type.
--- The variable's name is formed using the given string as the prefix.
---
-newLocalVar :: FastString -> Type -> VM Var
-newLocalVar fs ty
- = do u <- liftDs newUnique
-      return $ mkSysLocalOrCoVar fs u ty
-
--- |Make several fresh local variables with the given types.
--- The variable's names are formed using the given string as the prefix.
---
-newLocalVars :: FastString -> [Type] -> VM [Var]
-newLocalVars fs = mapM (newLocalVar fs)
-
--- |Make a new local dummy variable.
---
-newDummyVar :: Type -> VM Var
-newDummyVar = newLocalVar (fsLit "vv")
-
--- |Make a fresh type variable with the given kind.
--- The variable's name is formed using the given string as the prefix.
---
-newTyVar :: FastString -> Kind -> VM Var
-newTyVar fs k
- = do u <- liftDs newUnique
-      return $ mkTyVar (mkSysTvName u fs) k
-
--- |Make a fresh coercion variable with the given kind.
-newCoVar :: FastString -> Kind -> VM Var
-newCoVar fs k
-  = do u <- liftDs newUnique
-       return $ mkCoVar (mkSystemVarName u fs) k