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