diff options
Diffstat (limited to 'compiler/vectorise/Vectorise/Monad')
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/Base.hs | 245 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/Global.hs | 239 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/InstEnv.hs | 82 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/Local.hs | 102 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad/Naming.hs | 132 |
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 |