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