Major refactoring of CoAxioms
[ghc.git] / compiler / vectorise / Vectorise / Monad / Naming.hs
1 -- |Computations in the vectorisation monad concerned with naming and fresh variable generation.
2
3 module Vectorise.Monad.Naming
4 ( mkLocalisedName
5 , mkDerivedName
6 , mkVectId
7 , cloneVar
8 , newExportedVar
9 , newLocalVar
10 , newLocalVars
11 , newDummyVar
12 , newTyVar
13 )
14 where
15
16 import Vectorise.Monad.Base
17
18 import DsMonad
19 import TcType
20 import Type
21 import Var
22 import Name
23 import SrcLoc
24 import MkId
25 import Id
26 import FastString
27
28 import Control.Monad
29
30
31 -- Naming ---------------------------------------------------------------------
32
33 -- |Create a localised variant of a name, using the provided function to transform its `OccName`.
34 --
35 -- If the name external, encode the orignal name's module into the new 'OccName'. The result is
36 -- always an internal system name.
37 --
38 mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
39 mkLocalisedName mk_occ name
40 = do { mod <- liftDs getModuleDs
41 ; u <- liftDs newUnique
42 ; let occ_name = mkLocalisedOccName mod mk_occ name
43
44 new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
45 | otherwise = mkSystemName u occ_name
46
47 ; return new_name }
48
49 mkDerivedName :: (OccName -> OccName) -> Name -> VM Name
50 -- Similar to mkLocalisedName, but assumes the
51 -- incoming name is from this module.
52 -- Works on External names only
53 mkDerivedName mk_occ name
54 = do { u <- liftDs newUnique
55 ; return (mkExternalName u (nameModule name)
56 (mk_occ (nameOccName name))
57 (nameSrcSpan name)) }
58
59 -- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that
60 -- vectorised dfun ids must be dfuns again.
61 --
62 -- Force the new name to be a system name and, if the original was an external name, disambiguate
63 -- the new name with the module name of the original.
64 --
65 mkVectId :: Id -> Type -> VM Id
66 mkVectId id ty
67 = do { name <- mkLocalisedName mkVectOcc (getName id)
68 ; let id' | isDFunId id = MkId.mkDictFunId name tvs theta cls tys
69 | isExportedId id = Id.mkExportedLocalId name ty
70 | otherwise = Id.mkLocalId name ty
71 ; return id'
72 }
73 where
74 -- Decompose a dictionary function signature: \forall tvs. theta -> cls tys
75 -- NB: We do *not* use closures '(:->)' for vectorised predicate abstraction as dictionary
76 -- functions are always fully applied.
77 (tvs, theta, pty) = tcSplitSigmaTy ty
78 (cls, tys) = tcSplitDFunHead pty
79
80 -- |Make a fresh instance of this var, with a new unique.
81 --
82 cloneVar :: Var -> VM Var
83 cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
84
85 -- |Make a fresh exported variable with the given type.
86 --
87 newExportedVar :: OccName -> Type -> VM Var
88 newExportedVar occ_name ty
89 = do mod <- liftDs getModuleDs
90 u <- liftDs newUnique
91
92 let name = mkExternalName u mod occ_name noSrcSpan
93
94 return $ Id.mkExportedLocalId name ty
95
96 -- |Make a fresh local variable with the given type.
97 -- The variable's name is formed using the given string as the prefix.
98 --
99 newLocalVar :: FastString -> Type -> VM Var
100 newLocalVar fs ty
101 = do u <- liftDs newUnique
102 return $ mkSysLocal fs u ty
103
104 -- |Make several fresh local variables with the given types.
105 -- The variable's names are formed using the given string as the prefix.
106 --
107 newLocalVars :: FastString -> [Type] -> VM [Var]
108 newLocalVars fs = mapM (newLocalVar fs)
109
110 -- |Make a new local dummy variable.
111 --
112 newDummyVar :: Type -> VM Var
113 newDummyVar = newLocalVar (fsLit "vv")
114
115 -- |Make a fresh type variable with the given kind.
116 -- The variable's name is formed using the given string as the prefix.
117 --
118 newTyVar :: FastString -> Kind -> VM Var
119 newTyVar fs k
120 = do u <- liftDs newUnique
121 return $ mkTyVar (mkSysTvName u fs) k