cd0167517236bc090357cde3ad46bfbb0927b7fe
[matthijs/master-project/cλash.git] / BinderTools.hs
1 --
2 -- This module contains functions that manipulate binders in various ways.
3 --
4 module CLasH.Utils.Core.BinderTools where
5
6 -- Standard modules
7 import qualified Data.Accessor.Monad.Trans.State as MonadState
8
9 -- GHC API
10 import qualified CoreSyn
11 import qualified Type
12 import qualified UniqSupply
13 import qualified Unique
14 import qualified OccName
15 import qualified Name
16 import qualified Module
17 import qualified Var
18 import qualified SrcLoc
19 import qualified IdInfo
20 import qualified CoreUtils
21
22 -- Local imports
23 import CLasH.Translator.TranslatorTypes
24
25 -- Create a new Unique
26 mkUnique :: TranslatorSession Unique.Unique    
27 mkUnique = do
28   us <- MonadState.get tsUniqSupply 
29   let (us', us'') = UniqSupply.splitUniqSupply us
30   MonadState.set tsUniqSupply us'
31   return $ UniqSupply.uniqFromSupply us''
32
33 -- Create a new internal var with the given name and type. A Unique is
34 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
35 -- since the Unique is also stored in the name, but this ensures variable
36 -- names are unique in the output).
37 mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var
38 mkInternalVar str ty = do
39   uniq <- mkUnique
40   let occname = OccName.mkVarOcc (str ++ show uniq)
41   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
42   return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
43
44 -- Create a new type variable with the given name and kind. A Unique is
45 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
46 -- since the Unique is also stored in the name, but this ensures variable
47 -- names are unique in the output).
48 mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var
49 mkTypeVar str kind = do
50   uniq <- mkUnique
51   let occname = OccName.mkVarOcc (str ++ show uniq)
52   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
53   return $ Var.mkTyVar name kind
54
55 -- Creates a binder for the given expression with the given name. This
56 -- works for both value and type level expressions, so it can return a Var or
57 -- TyVar (which is just an alias for Var).
58 mkBinderFor :: CoreSyn.CoreExpr -> String -> TranslatorSession Var.Var
59 mkBinderFor (CoreSyn.Type ty) string = mkTypeVar string (Type.typeKind ty)
60 mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
61
62 -- Creates a reference to the given variable. This works for both a normal
63 -- variable as well as a type variable
64 mkReferenceTo :: Var.Var -> CoreSyn.CoreExpr
65 mkReferenceTo var | Var.isTyVar var = (CoreSyn.Type $ Type.mkTyVarTy var)
66                   | otherwise       = (CoreSyn.Var var)
67
68 cloneVar :: Var.Var -> TranslatorSession Var.Var
69 cloneVar v = do
70   uniq <- mkUnique
71   -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
72   -- contains, but vannillaIdInfo is always correct, since it means "no info").
73   return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
74
75 -- Creates a new function with the same name as the given binder (but with a
76 -- new unique) and with the given function body. Returns the new binder for
77 -- this function.
78 mkFunction :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreBndr
79 mkFunction bndr body = do
80   let ty = CoreUtils.exprType body
81   id <- cloneVar bndr
82   let newid = Var.setVarType id ty
83   addGlobalBind newid body
84   return newid
85
86 -- Returns the full name of a NamedThing, in the forum
87 -- modulename.occname
88 getFullString :: Name.NamedThing a => a -> String
89 getFullString thing = modstr ++ occstr
90   where
91     name    = Name.getName thing
92     modstr  = case Name.nameModule_maybe name of
93       Nothing -> ""
94       Just mod -> Module.moduleNameString (Module.moduleName mod) ++ "."
95     occstr  = Name.getOccString name