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