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