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