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