8c0a2ec93835605f964ea0745159b86a59739fd2
[matthijs/master-project/cλash.git] / VHDL.hs
1 --
2 -- Functions to generate VHDL from FlatFunctions
3 --
4 module VHDL where
5
6 import qualified Data.Foldable as Foldable
7 import qualified Maybe
8
9 import qualified Type
10 import qualified Name
11 import qualified TyCon
12 import Outputable ( showSDoc, ppr )
13
14 import qualified ForSyDe.Backend.VHDL.AST as AST
15
16 import VHDLTypes
17 import FlattenTypes
18 import TranslatorTypes
19
20 -- | Create an entity for a given function
21 createEntity ::
22   HsFunction        -- | The function signature
23   -> FuncData       -- | The function data collected so far
24   -> VHDLState ()
25
26 createEntity hsfunc fdata = 
27   let func = flatFunc fdata in
28   case func of
29     -- Skip (builtin) functions without a FlatFunction
30     Nothing -> do return ()
31     -- Create an entity for all other functions
32     Just flatfunc ->
33       
34       let 
35         sigs    = flat_sigs flatfunc
36         args    = flat_args flatfunc
37         res     = flat_res  flatfunc
38         args'   = map (fmap (mkMap sigs)) args
39         res'    = fmap (mkMap sigs) res
40         ent_decl' = createEntityAST hsfunc args' res'
41         entity' = Entity args' res' (Just ent_decl')
42       in
43         setEntity hsfunc entity'
44   where
45     mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
46     mkMap sigmap id =
47       (mkVHDLId nm, vhdl_ty ty)
48       where
49         info = Maybe.fromMaybe
50           (error $ "Signal not found in the name map? This should not happen!")
51           (lookup id sigmap)
52         nm = Maybe.fromMaybe
53           (error $ "Signal not named? This should not happen!")
54           (sigName info)
55         ty = sigTy info
56
57 -- | Create the VHDL AST for an entity
58 createEntityAST ::
59   HsFunction            -- | The signature of the function we're working with
60   -> [VHDLSignalMap]    -- | The entity's arguments
61   -> VHDLSignalMap      -- | The entity's result
62   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
63
64 createEntityAST hsfunc args res =
65   AST.EntityDec vhdl_id ports
66   where
67     vhdl_id = mkEntityId hsfunc
68     ports = concatMap (mapToPorts AST.In) args
69             ++ mapToPorts AST.Out res
70     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec] 
71     mapToPorts mode m =
72       map (mkIfaceSigDec mode) (Foldable.toList m)
73
74 -- | Create a port declaration
75 mkIfaceSigDec ::
76   AST.Mode                         -- | The mode for the port (In / Out)
77   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
78   -> AST.IfaceSigDec               -- | The resulting port declaration
79
80 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
81
82 -- | Generate a VHDL entity name for the given hsfunc
83 mkEntityId hsfunc =
84   -- TODO: This doesn't work for functions with multiple signatures!
85   mkVHDLId $ hsFuncName hsfunc
86
87 -- | Create an architecture for a given function
88 createArchitecture ::
89   HsFunction        -- | The function signature
90   -> FuncData       -- | The function data collected so far
91   -> VHDLState ()
92
93 createArchitecture hsfunc fdata = 
94   let func = flatFunc fdata in
95   case func of
96     -- Skip (builtin) functions without a FlatFunction
97     Nothing -> do return ()
98     -- Create an architecture for all other functions
99     Just flatfunc -> do
100       let sigs = flat_sigs flatfunc
101       let args = flat_args flatfunc
102       let res  = flat_res  flatfunc
103       let apps = flat_apps flatfunc
104       let entity_id = Maybe.fromMaybe
105                       (error $ "Building architecture without an entity? This should not happen!")
106                       (getEntityId fdata)
107       -- Create signal declarations for all signals that are not in args and
108       -- res
109       let sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
110       -- Create component instantiations for all function applications
111       insts <- mapM mkCompInsSm apps
112       let insts' = map AST.CSISm insts
113       let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) insts'
114       setArchitecture hsfunc arch
115
116 mkSigDec :: SignalInfo -> AST.SigDec
117 mkSigDec info =
118     AST.SigDec (mkVHDLId name) (vhdl_ty ty) Nothing
119   where
120     name = Maybe.fromMaybe
121       (error $ "Unnamed signal? This should not happen!")
122       (sigName info)
123     ty = sigTy info
124
125 -- | Transforms a flat function application to a VHDL component instantiation.
126 mkCompInsSm ::
127   FApp UnnamedSignal            -- | The application to look at.
128   -> VHDLState AST.CompInsSm    -- | The corresponding VHDL component instantiation.
129
130 mkCompInsSm app = do
131   return $ AST.CompInsSm label (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
132   where
133     entity_id = mkVHDLId "foo"
134     label     = mkVHDLId "app"
135     portmaps  = []
136
137 -- | Extracts the generated entity id from the given funcdata
138 getEntityId :: FuncData -> Maybe AST.VHDLId
139 getEntityId fdata =
140   case funcEntity fdata of
141     Nothing -> Nothing
142     Just e  -> case ent_decl e of
143       Nothing -> Nothing
144       Just (AST.EntityDec id _) -> Just id
145
146 getLibraryUnits ::
147   (HsFunction, FuncData)      -- | A function from the session
148   -> [AST.LibraryUnit]        -- | The library units it generates
149
150 getLibraryUnits (hsfunc, fdata) =
151   case funcEntity fdata of 
152     Nothing -> []
153     Just ent -> case ent_decl ent of
154       Nothing -> []
155       Just decl -> [AST.LUEntity decl]
156   ++
157   case funcArch fdata of
158     Nothing -> []
159     Just arch -> [AST.LUArch arch]
160
161 -- | The VHDL Bit type
162 bit_ty :: AST.TypeMark
163 bit_ty = AST.unsafeVHDLBasicId "Bit"
164
165 -- Translate a Haskell type to a VHDL type
166 vhdl_ty :: Type.Type -> AST.TypeMark
167 vhdl_ty ty = Maybe.fromMaybe
168   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
169   (vhdl_ty_maybe ty)
170
171 -- Translate a Haskell type to a VHDL type
172 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
173 vhdl_ty_maybe ty =
174   case Type.splitTyConApp_maybe ty of
175     Just (tycon, args) ->
176       let name = TyCon.tyConName tycon in
177         -- TODO: Do something more robust than string matching
178         case Name.getOccString name of
179           "Bit"      -> Just bit_ty
180           otherwise  -> Nothing
181     otherwise -> Nothing
182
183 -- Shortcut
184 mkVHDLId :: String -> AST.VHDLId
185 mkVHDLId = AST.unsafeVHDLBasicId