Add the new HsTools module.
[matthijs/master-project/cλash.git] / VHDL.hs
1 --
2 -- Functions to generate VHDL from FlatFunctions
3 --
4 module VHDL where
5
6 -- Standard modules
7 import qualified Data.Foldable as Foldable
8 import qualified Data.List as List
9 import qualified Data.Map as Map
10 import qualified Maybe
11 import qualified Control.Monad as Monad
12 import qualified Control.Arrow as Arrow
13 import qualified Control.Monad.Trans.State as State
14 import qualified Data.Traversable as Traversable
15 import qualified Data.Monoid as Monoid
16 import Data.Accessor
17 import qualified Data.Accessor.MonadState as MonadState
18
19 -- ForSyDe
20 import qualified ForSyDe.Backend.VHDL.AST as AST
21
22 -- GHC API
23 import qualified Type
24 import qualified Name
25 import qualified TyCon
26 import Outputable ( showSDoc, ppr )
27
28 -- Local imports
29 import VHDLTypes
30 import Flatten
31 import FlattenTypes
32 import TranslatorTypes
33 import HsValueMap
34 import Pretty
35
36 createDesignFiles ::
37   FlatFuncMap
38   -> [(AST.VHDLId, AST.DesignFile)]
39
40 createDesignFiles flatfuncmap =
41   (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) :
42   map (Arrow.second $ AST.DesignFile full_context) units
43   
44   where
45     init_session = VHDLSession Map.empty builtin_funcs
46     (units, final_session) = 
47       State.runState (createLibraryUnits flatfuncmap) init_session
48     ty_decls = Map.elems (final_session ^. vsTypes)
49     ieee_context = [
50         AST.Library $ mkVHDLId "IEEE",
51         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All
52       ]
53     full_context =
54       (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All)
55       : ieee_context
56     type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
57
58 createLibraryUnits ::
59   FlatFuncMap
60   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
61
62 createLibraryUnits flatfuncmap = do
63   let hsfuncs = Map.keys flatfuncmap
64   let flatfuncs = Map.elems flatfuncmap
65   entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
66   archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
67   return $ zipWith 
68     (\ent arch -> 
69       let AST.EntityDec id _ = ent in 
70       (id, [AST.LUEntity ent, AST.LUArch arch])
71     )
72     entities archs
73
74 -- | Create an entity for a given function
75 createEntity ::
76   HsFunction -- | The function signature
77   -> FlatFunction -- | The FlatFunction
78   -> VHDLState AST.EntityDec -- | The resulting entity
79
80 createEntity hsfunc flatfunc = do
81       let sigs    = flat_sigs flatfunc
82       let args    = flat_args flatfunc
83       let res     = flat_res  flatfunc
84       args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
85       res' <- Traversable.traverse (mkMap sigs) res
86       let ent_decl' = createEntityAST hsfunc args' res'
87       let AST.EntityDec entity_id _ = ent_decl' 
88       let signature = Entity entity_id args' res'
89       modA vsSignatures (Map.insert hsfunc signature)
90       return ent_decl'
91   where
92     mkMap :: 
93       [(SignalId, SignalInfo)] 
94       -> SignalId 
95       -> VHDLState VHDLSignalMapElement
96     -- We only need the vsTypes element from the state
97     mkMap sigmap = MonadState.lift vsTypes . (\id ->
98       let
99         info = Maybe.fromMaybe
100           (error $ "Signal not found in the name map? This should not happen!")
101           (lookup id sigmap)
102         nm = Maybe.fromMaybe
103           (error $ "Signal not named? This should not happen!")
104           (sigName info)
105         ty = sigTy info
106       in
107         if isPortSigUse $ sigUse info
108           then do
109             type_mark <- vhdl_ty ty
110             return $ Just (mkVHDLId nm, type_mark)
111           else
112             return $ Nothing
113        )
114
115   -- | Create the VHDL AST for an entity
116 createEntityAST ::
117   HsFunction            -- | The signature of the function we're working with
118   -> [VHDLSignalMap]    -- | The entity's arguments
119   -> VHDLSignalMap      -- | The entity's result
120   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
121
122 createEntityAST hsfunc args res =
123   AST.EntityDec vhdl_id ports
124   where
125     vhdl_id = mkEntityId hsfunc
126     ports = concatMap (mapToPorts AST.In) args
127             ++ mapToPorts AST.Out res
128             ++ clk_port
129     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec] 
130     mapToPorts mode m =
131       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
132     -- Add a clk port if we have state
133     clk_port = if hasState hsfunc
134       then
135         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
136       else
137         []
138
139 -- | Create a port declaration
140 mkIfaceSigDec ::
141   AST.Mode                         -- | The mode for the port (In / Out)
142   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
143   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
144
145 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
146 mkIfaceSigDec _ Nothing = Nothing
147
148 -- | Generate a VHDL entity name for the given hsfunc
149 mkEntityId hsfunc =
150   -- TODO: This doesn't work for functions with multiple signatures!
151   mkVHDLId $ hsFuncName hsfunc
152
153 -- | Create an architecture for a given function
154 createArchitecture ::
155   HsFunction -- ^ The function signature
156   -> FlatFunction -- ^ The FlatFunction
157   -> VHDLState AST.ArchBody -- ^ The architecture for this function
158
159 createArchitecture hsfunc flatfunc = do
160   signaturemap <- getA vsSignatures
161   let signature = Maybe.fromMaybe 
162         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
163         (Map.lookup hsfunc signaturemap)
164   let entity_id = ent_id signature
165   -- Create signal declarations for all internal and state signals
166   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
167   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
168   -- Create concurrent statements for all signal definitions
169   let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
170   return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
171   where
172     sigs = flat_sigs flatfunc
173     args = flat_args flatfunc
174     res  = flat_res  flatfunc
175     defs = flat_defs flatfunc
176     procs = map mkStateProcSm (makeStatePairs flatfunc)
177     procs' = map AST.CSPSm procs
178     -- mkSigDec only uses vsTypes from the state
179     mkSigDec' = MonadState.lift vsTypes . mkSigDec
180
181 -- | Looks up all pairs of old state, new state signals, together with
182 --   the state id they represent.
183 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
184 makeStatePairs flatfunc =
185   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) 
186     | old_info <- map snd (flat_sigs flatfunc)
187     , new_info <- map snd (flat_sigs flatfunc)
188         -- old_info must be an old state (and, because of the next equality,
189         -- new_info must be a new state).
190         , Maybe.isJust $ oldStateId $ sigUse old_info
191         -- And the state numbers must match
192     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
193
194     -- Replace the second tuple element with the corresponding SignalInfo
195     --args_states = map (Arrow.second $ signalInfo sigs) args
196 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
197 mkStateProcSm (num, old, new) =
198   AST.ProcSm label [clk] [statement]
199   where
200     label       = mkVHDLId $ "state_" ++ (show num)
201     clk         = mkVHDLId "clk"
202     rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
203     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
204     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
205     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
206     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
207
208 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
209 mkSigDec info =
210   let use = sigUse info in
211   if isInternalSigUse use || isStateSigUse use then do
212     type_mark <- vhdl_ty ty
213     return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
214   else
215     return Nothing
216   where
217     ty = sigTy info
218
219 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
220 --   is not named.
221 getSignalId :: SignalInfo -> AST.VHDLId
222 getSignalId info =
223     mkVHDLId $ Maybe.fromMaybe
224       (error $ "Unnamed signal? This should not happen!")
225       (sigName info)
226
227 -- | Transforms a signal definition into a VHDL concurrent statement
228 mkConcSm ::
229   SignatureMap             -- ^ The interfaces of functions in the session
230   -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
231   -> SigDef                -- ^ The signal definition 
232   -> Int                   -- ^ A number that will be unique for all
233                            --   concurrent statements in the architecture.
234   -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
235
236 mkConcSm signatures sigs (FApp hsfunc args res) num =
237   let 
238     signature = Maybe.fromMaybe
239         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
240         (Map.lookup hsfunc signatures)
241     entity_id = ent_id signature
242     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
243     -- Add a clk port if we have state
244     clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
245     portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
246   in
247     AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
248
249 mkConcSm _ sigs (UncondDef src dst) _ =
250   let
251     src_expr  = vhdl_expr src
252     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
253     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
254     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
255   in
256     AST.CSSASm assign
257   where
258     vhdl_expr (Left id) = mkIdExpr sigs id
259     vhdl_expr (Right expr) =
260       case expr of
261         (EqLit id lit) ->
262           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
263         (Literal lit) ->
264           AST.PrimLit lit
265         (Eq a b) ->
266           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
267
268 mkConcSm _ sigs (CondDef cond true false dst) _ =
269   let
270     cond_expr  = mkIdExpr sigs cond
271     true_expr  = mkIdExpr sigs true
272     false_expr  = mkIdExpr sigs false
273     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
274     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
275     whenelse = AST.WhenElse true_wform cond_expr
276     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
277     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
278   in
279     AST.CSSASm assign
280
281 -- | Turn a SignalId into a VHDL Expr
282 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
283 mkIdExpr sigs id =
284   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
285   AST.PrimName src_name
286
287 mkAssocElems :: 
288   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
289   -> [SignalMap]                -- | The signals that are applied to function
290   -> SignalMap                  -- | the signals in which to store the function result
291   -> Entity                     -- | The entity to map against.
292   -> [AST.AssocElem]            -- | The resulting port maps
293
294 mkAssocElems sigmap args res entity =
295     -- Create the actual AssocElems
296     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
297   where
298     -- Turn the ports and signals from a map into a flat list. This works,
299     -- since the maps must have an identical form by definition. TODO: Check
300     -- the similar form?
301     arg_ports = concat (map Foldable.toList (ent_args entity))
302     res_ports = Foldable.toList (ent_res entity)
303     arg_sigs  = (concat (map Foldable.toList args))
304     res_sigs  = Foldable.toList res
305     -- Extract the id part from the (id, type) tuple
306     ports     = (map (fmap fst) (arg_ports ++ res_ports)) 
307     -- Translate signal numbers into names
308     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
309
310 -- | Look up a signal in the signal name map
311 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
312 lookupSigName sigs sig = name
313   where
314     info = Maybe.fromMaybe
315       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
316       (lookup sig sigs)
317     name = Maybe.fromMaybe
318       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
319       (sigName info)
320
321 -- | Create an VHDL port -> signal association
322 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
323 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal))) 
324 mkAssocElem Nothing _ = Nothing
325
326 -- | The VHDL Bit type
327 bit_ty :: AST.TypeMark
328 bit_ty = AST.unsafeVHDLBasicId "Bit"
329
330 -- | The VHDL Boolean type
331 bool_ty :: AST.TypeMark
332 bool_ty = AST.unsafeVHDLBasicId "Boolean"
333
334 -- | The VHDL std_logic
335 std_logic_ty :: AST.TypeMark
336 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
337
338 -- Translate a Haskell type to a VHDL type
339 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
340 vhdl_ty ty = do
341   typemap <- State.get
342   let builtin_ty = do -- See if this is a tycon and lookup its name
343         (tycon, args) <- Type.splitTyConApp_maybe ty
344         let name = Name.getOccString (TyCon.tyConName tycon)
345         Map.lookup name builtin_types
346   -- If not a builtin type, try the custom types
347   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
348   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
349     -- Found a type, return it
350     Just t -> return t
351     -- No type yet, try to construct it
352     Nothing -> do
353       let new_ty = do
354             -- Use the Maybe Monad for failing when one of these fails
355             (tycon, args) <- Type.splitTyConApp_maybe ty
356             let name = Name.getOccString (TyCon.tyConName tycon)
357             case name of
358               "FSVec" -> Just $ mk_fsvec_ty ty args
359               otherwise -> Nothing
360       -- Return new_ty when a new type was successfully created
361       Maybe.fromMaybe 
362         (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
363         new_ty
364
365 -- | Create a VHDL type belonging to a FSVec Haskell type
366 mk_fsvec_ty ::
367   Type.Type -- ^ The Haskell type to create a VHDL type for
368   -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
369   -> TypeState AST.TypeMark -- The typemark created.
370
371 mk_fsvec_ty ty args = do
372   -- Assume there are two type arguments
373   let [len, el_ty] = args 
374   -- TODO: Find actual number
375   -- Construct the type id, but filter out dots (since these are not allowed).
376   let ty_id = mkVHDLId $ filter (/='.') ("vector_" ++ (show len))
377   -- TODO: Use el_ty
378   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
379   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
380   let ty_dec = AST.TypeDec ty_id ty_def
381   -- TODO: Check name uniqueness
382   State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
383   return ty_id
384
385
386 builtin_types = 
387   Map.fromList [
388     ("Bit", std_logic_ty),
389     ("Bool", bool_ty) -- TysWiredIn.boolTy
390   ]
391
392 -- Shortcut
393 mkVHDLId :: String -> AST.VHDLId
394 mkVHDLId s = 
395   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
396   where
397     -- Strip invalid characters.
398     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
399     -- Strip multiple adjacent underscores
400     strip_multiscore = concat . map (\cs -> 
401         case cs of 
402           ('_':_) -> "_"
403           _ -> cs
404       ) . List.group
405
406 -- | A consise representation of a (set of) ports on a builtin function
407 type PortMap = HsValueMap (String, AST.TypeMark)
408 -- | A consise representation of a builtin function
409 data BuiltIn = BuiltIn String [PortMap] PortMap
410
411 -- | Translate a list of concise representation of builtin functions to a
412 --   SignatureMap
413 mkBuiltins :: [BuiltIn] -> SignatureMap
414 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
415     (HsFunction name (map useAsPort args) (useAsPort res),
416      Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
417   )
418
419 builtin_hsfuncs = Map.keys builtin_funcs
420 builtin_funcs = mkBuiltins
421   [ 
422     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
423     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
424     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
425     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
426   ]
427
428 -- | Map a port specification of a builtin function to a VHDL Signal to put in
429 --   a VHDLSignalMap
430 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
431 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))
432
433 -- vim: set ts=8 sw=2 sts=2 expandtab: