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