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 Maybe
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Arrow as Arrow
  11 import qualified Data.Traversable as Traversable
  12 import qualified Data.Monoid as Monoid
  13
  14 import qualified Type
  15 import qualified TysWiredIn
  16 import qualified Name
  17 import qualified TyCon
  18 import Outputable ( showSDoc, ppr )
  19
  20 import qualified ForSyDe.Backend.VHDL.AST as AST
  21
  22 import VHDLTypes
  23 import Flatten
  24 import FlattenTypes
  25 import TranslatorTypes
  26 import Pretty
  27
  28 getDesignFiles :: [FuncData] -> [AST.DesignFile]
  29 getDesignFiles funcs =
  30   map (AST.DesignFile context) units
  31   where
  32     units = filter (not.null) $ map getLibraryUnits funcs
  33     context = [
  34       AST.Library $ mkVHDLId "IEEE",
  35       AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
  36
  37 -- | Create an entity for a given function
  38 createEntity ::
  39   HsFunction        -- | The function signature
  40   -> FuncData       -- | The function data collected so far
  41   -> VHDLState ()
  42
  43 createEntity hsfunc fdata =
  44   let func = flatFunc fdata in
  45   case func of
  46     -- Skip (builtin) functions without a FlatFunction
  47     Nothing -> do return ()
  48     -- Create an entity for all other functions
  49     Just flatfunc ->
  50       let
  51         sigs    = flat_sigs flatfunc
  52         args    = flat_args flatfunc
  53         res     = flat_res  flatfunc
  54         (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
  55         (ty_decls', res') = Traversable.traverse (mkMap sigs) res
  56         -- TODO: Unique ty_decls
  57         ent_decl' = createEntityAST hsfunc args' res'
  58         pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
  59         pkg_decl = if null ty_decls && null ty_decls'
  60           then Nothing
  61           else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
  62         AST.EntityDec entity_id _ = ent_decl'
  63         entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
  64       in do
  65         setEntity hsfunc entity'
  66   where
  67     mkMap ::
  68       [(SignalId, SignalInfo)]
  69       -> SignalId
  70       -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
  71     mkMap sigmap id =
  72       if isPortSigUse $ sigUse info
  73         then
  74           let (decs, type_mark) = vhdl_ty ty in
  75           (decs, Just (mkVHDLId nm, type_mark))
  76         else
  77           (Monoid.mempty, Nothing)
  78       where
  79         info = Maybe.fromMaybe
  80           (error $ "Signal not found in the name map? This should not happen!")
  81           (lookup id sigmap)
  82         nm = Maybe.fromMaybe
  83           (error $ "Signal not named? This should not happen!")
  84           (sigName info)
  85         ty = sigTy info
  86
  87   -- | Create the VHDL AST for an entity
  88 createEntityAST ::
  89   HsFunction            -- | The signature of the function we're working with
  90   -> [VHDLSignalMap]    -- | The entity's arguments
  91   -> VHDLSignalMap      -- | The entity's result
  92   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  93
  94 createEntityAST hsfunc args res =
  95   AST.EntityDec vhdl_id ports
  96   where
  97     vhdl_id = mkEntityId hsfunc
  98     ports = concatMap (mapToPorts AST.In) args
  99             ++ mapToPorts AST.Out res
 100             ++ clk_port
 101     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 102     mapToPorts mode m =
 103       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 104     -- Add a clk port if we have state
 105     clk_port = if hasState hsfunc
 106       then
 107         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
 108       else
 109         []
 110
 111 -- | Create a port declaration
 112 mkIfaceSigDec ::
 113   AST.Mode                         -- | The mode for the port (In / Out)
 114   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 115   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 116
 117 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 118 mkIfaceSigDec _ Nothing = Nothing
 119
 120 -- | Generate a VHDL entity name for the given hsfunc
 121 mkEntityId hsfunc =
 122   -- TODO: This doesn't work for functions with multiple signatures!
 123   mkVHDLId $ hsFuncName hsfunc
 124
 125 -- | Create an architecture for a given function
 126 createArchitecture ::
 127   HsFunction        -- | The function signature
 128   -> FuncData       -- | The function data collected so far
 129   -> VHDLState ()
 130
 131 createArchitecture hsfunc fdata =
 132   let func = flatFunc fdata in
 133   case func of
 134     -- Skip (builtin) functions without a FlatFunction
 135     Nothing -> do return ()
 136     -- Create an architecture for all other functions
 137     Just flatfunc -> do
 138       let sigs = flat_sigs flatfunc
 139       let args = flat_args flatfunc
 140       let res  = flat_res  flatfunc
 141       let defs = flat_defs flatfunc
 142       let entity_id = Maybe.fromMaybe
 143                       (error $ "Building architecture without an entity? This should not happen!")
 144                       (getEntityId fdata)
 145       -- Create signal declarations for all signals that are not in args and
 146       -- res
 147       let (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
 148       -- TODO: Unique ty_decls
 149       -- TODO: Store ty_decls somewhere
 150       -- Create concurrent statements for all signal definitions
 151       statements <- mapM (mkConcSm sigs) defs
 152       let procs = map mkStateProcSm (makeStatePairs flatfunc)
 153       let procs' = map AST.CSPSm procs
 154       let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 155       setArchitecture hsfunc arch
 156
 157 -- | Looks up all pairs of old state, new state signals, together with
 158 --   the state id they represent.
 159 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 160 makeStatePairs flatfunc =
 161   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 162     | old_info <- map snd (flat_sigs flatfunc)
 163     , new_info <- map snd (flat_sigs flatfunc)
 164         -- old_info must be an old state (and, because of the next equality,
 165         -- new_info must be a new state).
 166         , Maybe.isJust $ oldStateId $ sigUse old_info
 167         -- And the state numbers must match
 168     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 169
 170     -- Replace the second tuple element with the corresponding SignalInfo
 171     --args_states = map (Arrow.second $ signalInfo sigs) args
 172 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 173 mkStateProcSm (num, old, new) =
 174   AST.ProcSm label [clk] [statement]
 175   where
 176     label       = mkVHDLId $ "state_" ++ (show num)
 177     clk         = mkVHDLId "clk"
 178     rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
 179     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 180     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 181     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 182     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 183
 184 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
 185 mkSigDec info =
 186   let use = sigUse info in
 187   if isInternalSigUse use || isStateSigUse use then
 188     let (ty_decls, type_mark) = vhdl_ty ty in
 189     (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
 190   else
 191     ([], Nothing)
 192   where
 193     ty = sigTy info
 194
 195 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 196 --   is not named.
 197 getSignalId :: SignalInfo -> AST.VHDLId
 198 getSignalId info =
 199     mkVHDLId $ Maybe.fromMaybe
 200       (error $ "Unnamed signal? This should not happen!")
 201       (sigName info)
 202
 203 -- | Transforms a signal definition into a VHDL concurrent statement
 204 mkConcSm ::
 205   [(SignalId, SignalInfo)] -- | The signals in the current architecture
 206   -> SigDef                -- | The signal definition
 207   -> VHDLState AST.ConcSm    -- | The corresponding VHDL component instantiation.
 208
 209 mkConcSm sigs (FApp hsfunc args res) = do
 210   fdata_maybe <- getFunc hsfunc
 211   let fdata = Maybe.fromMaybe
 212         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
 213         fdata_maybe
 214   let entity = Maybe.fromMaybe
 215         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
 216         (funcEntity fdata)
 217   let entity_id = ent_id entity
 218   label <- uniqueName (AST.fromVHDLId entity_id)
 219   -- Add a clk port if we have state
 220   let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
 221   let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
 222   return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 223
 224 mkConcSm sigs (UncondDef src dst) = do
 225   let src_expr  = vhdl_expr src
 226   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 227   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 228   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 229   return $ AST.CSSASm assign
 230   where
 231     vhdl_expr (Left id) = mkIdExpr sigs id
 232     vhdl_expr (Right expr) =
 233       case expr of
 234         (EqLit id lit) ->
 235           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 236         (Literal lit) ->
 237           AST.PrimLit lit
 238         (Eq a b) ->
 239           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 240
 241 mkConcSm sigs (CondDef cond true false dst) = do
 242   let cond_expr  = mkIdExpr sigs cond
 243   let true_expr  = mkIdExpr sigs true
 244   let false_expr  = mkIdExpr sigs false
 245   let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 246   let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 247   let whenelse = AST.WhenElse true_wform cond_expr
 248   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 249   let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 250   return $ AST.CSSASm assign
 251
 252 -- | Turn a SignalId into a VHDL Expr
 253 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 254 mkIdExpr sigs id =
 255   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 256   AST.PrimName src_name
 257
 258 mkAssocElems ::
 259   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 260   -> [SignalMap]                -- | The signals that are applied to function
 261   -> SignalMap                  -- | the signals in which to store the function result
 262   -> Entity                     -- | The entity to map against.
 263   -> [AST.AssocElem]            -- | The resulting port maps
 264
 265 mkAssocElems sigmap args res entity =
 266     -- Create the actual AssocElems
 267     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 268   where
 269     -- Turn the ports and signals from a map into a flat list. This works,
 270     -- since the maps must have an identical form by definition. TODO: Check
 271     -- the similar form?
 272     arg_ports = concat (map Foldable.toList (ent_args entity))
 273     res_ports = Foldable.toList (ent_res entity)
 274     arg_sigs  = (concat (map Foldable.toList args))
 275     res_sigs  = Foldable.toList res
 276     -- Extract the id part from the (id, type) tuple
 277     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 278     -- Translate signal numbers into names
 279     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 280
 281 -- | Look up a signal in the signal name map
 282 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 283 lookupSigName sigs sig = name
 284   where
 285     info = Maybe.fromMaybe
 286       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 287       (lookup sig sigs)
 288     name = Maybe.fromMaybe
 289       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 290       (sigName info)
 291
 292 -- | Create an VHDL port -> signal association
 293 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 294 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
 295 mkAssocElem Nothing _ = Nothing
 296
 297 -- | Extracts the generated entity id from the given funcdata
 298 getEntityId :: FuncData -> Maybe AST.VHDLId
 299 getEntityId fdata =
 300   case funcEntity fdata of
 301     Nothing -> Nothing
 302     Just e  -> case ent_decl e of
 303       Nothing -> Nothing
 304       Just (AST.EntityDec id _) -> Just id
 305
 306 getLibraryUnits ::
 307   FuncData                    -- | A function from the session
 308   -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 309
 310 getLibraryUnits fdata =
 311   case funcEntity fdata of
 312     Nothing -> []
 313     Just ent ->
 314       case ent_decl ent of
 315       Nothing -> []
 316       Just decl ->
 317         case funcArch fdata of
 318           Nothing -> []
 319           Just arch ->
 320               [AST.LUEntity decl, AST.LUArch arch]
 321               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 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 -> ([AST.TypeDec], AST.TypeMark)
 337 vhdl_ty ty = Maybe.fromMaybe
 338   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 339   (vhdl_ty_maybe ty)
 340
 341 -- Translate a Haskell type to a VHDL type, optionally generating a type
 342 -- declaration for the type.
 343 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 344 vhdl_ty_maybe ty =
 345   if Type.coreEqType ty TysWiredIn.boolTy
 346     then
 347       Just ([], bool_ty)
 348     else
 349       case Type.splitTyConApp_maybe ty of
 350         Just (tycon, args) ->
 351           let name = TyCon.tyConName tycon in
 352             -- TODO: Do something more robust than string matching
 353             case Name.getOccString name of
 354               "Bit"      -> Just ([], std_logic_ty)
 355               "FSVec"    ->
 356                 let
 357                   [len, el_ty] = args
 358                   -- TODO: Find actual number
 359                   ty_id = mkVHDLId ("vector_" ++ (show len))
 360                   -- TODO: Use el_ty
 361                   range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
 362                   ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 363                   ty_dec = AST.TypeDec ty_id ty_def
 364                 in
 365                   Just ([ty_dec], ty_id)
 366               otherwise  -> Nothing
 367         otherwise -> Nothing
 368
 369 -- Shortcut
 370 mkVHDLId :: String -> AST.VHDLId
 371 mkVHDLId s =
 372   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
 373   where
 374     -- Strip invalid characters.
 375     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 376     -- Strip multiple adjacent underscores
 377     strip_multiscore = concat . map (\cs ->
 378         case cs of
 379           ('_':_) -> "_"
 380           _ -> cs
 381       ) . List.group