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