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 Data.Map as Map
   9 import qualified Maybe
  10 import qualified Control.Monad as Monad
  11 import qualified Control.Arrow as Arrow
  12 import qualified Control.Monad.Trans.State as State
  13 import qualified Data.Traversable as Traversable
  14 import qualified Data.Monoid as Monoid
  15 import Data.Accessor
  16 import qualified Data.Accessor.MonadState as MonadState
  17
  18 import qualified Type
  19 import qualified TysWiredIn
  20 import qualified Name
  21 import qualified TyCon
  22 import Outputable ( showSDoc, ppr )
  23
  24 import qualified ForSyDe.Backend.VHDL.AST as AST
  25
  26 import VHDLTypes
  27 import Flatten
  28 import FlattenTypes
  29 import TranslatorTypes
  30 import HsValueMap
  31 import Pretty
  32
  33 createDesignFiles ::
  34   FlatFuncMap
  35   -> [(AST.VHDLId, AST.DesignFile)]
  36
  37 createDesignFiles flatfuncmap =
  38   -- TODO: Output types
  39   (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) :
  40   map (Arrow.second $ AST.DesignFile full_context) units
  41
  42   where
  43     init_session = VHDLSession Map.empty builtin_funcs
  44     (units, final_session) =
  45       State.runState (createLibraryUnits flatfuncmap) init_session
  46     ty_decls = Map.elems (final_session ^. vsTypes)
  47     ieee_context = [
  48         AST.Library $ mkVHDLId "IEEE",
  49         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All
  50       ]
  51     full_context =
  52       (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All)
  53       : ieee_context
  54     type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
  55
  56 createLibraryUnits ::
  57   FlatFuncMap
  58   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  59
  60 createLibraryUnits flatfuncmap = do
  61   let hsfuncs = Map.keys flatfuncmap
  62   let flatfuncs = Map.elems flatfuncmap
  63   entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
  64   archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
  65   return $ zipWith
  66     (\ent arch ->
  67       let AST.EntityDec id _ = ent in
  68       (id, [AST.LUEntity ent, AST.LUArch arch])
  69     )
  70     entities archs
  71
  72 -- | Create an entity for a given function
  73 createEntity ::
  74   HsFunction -- | The function signature
  75   -> FlatFunction -- | The FlatFunction
  76   -> VHDLState AST.EntityDec -- | The resulting entity
  77
  78 createEntity hsfunc flatfunc = do
  79       let sigs    = flat_sigs flatfunc
  80       let args    = flat_args flatfunc
  81       let res     = flat_res  flatfunc
  82       args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
  83       res' <- Traversable.traverse (mkMap sigs) res
  84       let ent_decl' = createEntityAST hsfunc args' res'
  85       let AST.EntityDec entity_id _ = ent_decl'
  86       let signature = Entity entity_id args' res'
  87       modA vsSignatures (Map.insert hsfunc signature)
  88       return ent_decl'
  89   where
  90     mkMap ::
  91       [(SignalId, SignalInfo)]
  92       -> SignalId
  93       -> VHDLState VHDLSignalMapElement
  94     -- We only need the vsTypes element from the state
  95     mkMap sigmap = MonadState.lift vsTypes . (\id ->
  96       let
  97         info = Maybe.fromMaybe
  98           (error $ "Signal not found in the name map? This should not happen!")
  99           (lookup id sigmap)
 100         nm = Maybe.fromMaybe
 101           (error $ "Signal not named? This should not happen!")
 102           (sigName info)
 103         ty = sigTy info
 104       in
 105         if isPortSigUse $ sigUse info
 106           then do
 107             type_mark <- vhdl_ty ty
 108             return $ Just (mkVHDLId nm, type_mark)
 109           else
 110             return $ Nothing
 111        )
 112
 113   -- | Create the VHDL AST for an entity
 114 createEntityAST ::
 115   HsFunction            -- | The signature of the function we're working with
 116   -> [VHDLSignalMap]    -- | The entity's arguments
 117   -> VHDLSignalMap      -- | The entity's result
 118   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
 119
 120 createEntityAST hsfunc args res =
 121   AST.EntityDec vhdl_id ports
 122   where
 123     vhdl_id = mkEntityId hsfunc
 124     ports = concatMap (mapToPorts AST.In) args
 125             ++ mapToPorts AST.Out res
 126             ++ clk_port
 127     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 128     mapToPorts mode m =
 129       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 130     -- Add a clk port if we have state
 131     clk_port = if hasState hsfunc
 132       then
 133         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
 134       else
 135         []
 136
 137 -- | Create a port declaration
 138 mkIfaceSigDec ::
 139   AST.Mode                         -- | The mode for the port (In / Out)
 140   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 141   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 142
 143 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 144 mkIfaceSigDec _ Nothing = Nothing
 145
 146 -- | Generate a VHDL entity name for the given hsfunc
 147 mkEntityId hsfunc =
 148   -- TODO: This doesn't work for functions with multiple signatures!
 149   mkVHDLId $ hsFuncName hsfunc
 150
 151 -- | Create an architecture for a given function
 152 createArchitecture ::
 153   HsFunction -- ^ The function signature
 154   -> FlatFunction -- ^ The FlatFunction
 155   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 156
 157 createArchitecture hsfunc flatfunc = do
 158   signaturemap <- getA vsSignatures
 159   let signature = Maybe.fromMaybe
 160         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 161         (Map.lookup hsfunc signaturemap)
 162   let entity_id = ent_id signature
 163   -- Create signal declarations for all internal and state signals
 164   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
 165   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 166   -- Create concurrent statements for all signal definitions
 167   let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
 168   return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 169   where
 170     sigs = flat_sigs flatfunc
 171     args = flat_args flatfunc
 172     res  = flat_res  flatfunc
 173     defs = flat_defs flatfunc
 174     -- TODO: Unique ty_decls
 175     -- TODO: Store ty_decls somewhere
 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   State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
 382   return ty_id
 383
 384
 385 builtin_types =
 386   Map.fromList [
 387     ("Bit", std_logic_ty),
 388     ("Bool", bool_ty) -- TysWiredIn.boolTy
 389   ]
 390
 391 -- Shortcut
 392 mkVHDLId :: String -> AST.VHDLId
 393 mkVHDLId s =
 394   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
 395   where
 396     -- Strip invalid characters.
 397     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 398     -- Strip multiple adjacent underscores
 399     strip_multiscore = concat . map (\cs ->
 400         case cs of
 401           ('_':_) -> "_"
 402           _ -> cs
 403       ) . List.group
 404
 405 -- | A consise representation of a (set of) ports on a builtin function
 406 type PortMap = HsValueMap (String, AST.TypeMark)
 407 -- | A consise representation of a builtin function
 408 data BuiltIn = BuiltIn String [PortMap] PortMap
 409
 410 -- | Translate a list of concise representation of builtin functions to a
 411 --   SignatureMap
 412 mkBuiltins :: [BuiltIn] -> SignatureMap
 413 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 414     (HsFunction name (map useAsPort args) (useAsPort res),
 415      Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
 416   )
 417
 418 builtin_hsfuncs = Map.keys builtin_funcs
 419 builtin_funcs = mkBuiltins
 420   [
 421     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 422     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 423     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 424     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 425   ]
 426
 427 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 428 --   a VHDLSignalMap
 429 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 430 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))