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