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 Data.Traversable as Traversable
  13 import qualified Data.Monoid as Monoid
  14 import Data.Accessor
  15
  16 import qualified Type
  17 import qualified TysWiredIn
  18 import qualified Name
  19 import qualified TyCon
  20 import Outputable ( showSDoc, ppr )
  21
  22 import qualified ForSyDe.Backend.VHDL.AST as AST
  23
  24 import VHDLTypes
  25 import Flatten
  26 import FlattenTypes
  27 import TranslatorTypes
  28 import Pretty
  29
  30 getDesignFiles :: [FuncData] -> [AST.DesignFile]
  31 getDesignFiles funcs =
  32   map (AST.DesignFile context) units
  33   where
  34     units = filter (not.null) $ map getLibraryUnits funcs
  35     context = [
  36       AST.Library $ mkVHDLId "IEEE",
  37       AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
  38
  39 -- | Create an entity for a given function
  40 createEntity ::
  41   HsFunction        -- | The function signature
  42   -> FuncData       -- | The function data collected so far
  43   -> Maybe Entity   -- | The resulting entity. Should return the existing
  44                     ---  Entity for builtin functions.
  45
  46 createEntity hsfunc fdata =
  47   case fdata ^. fdFlatFunc of
  48     -- Skip (builtin) functions without a FlatFunction
  49     Nothing -> fdata ^. fdEntity
  50     -- Create an entity for all other functions
  51     Just flatfunc ->
  52       let
  53         sigs    = flat_sigs flatfunc
  54         args    = flat_args flatfunc
  55         res     = flat_res  flatfunc
  56         (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
  57         (ty_decls', res') = Traversable.traverse (mkMap sigs) res
  58         -- TODO: Unique ty_decls
  59         ent_decl' = createEntityAST hsfunc args' res'
  60         pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
  61         pkg_decl = if null ty_decls && null ty_decls'
  62           then Nothing
  63           else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
  64         AST.EntityDec entity_id _ = ent_decl'
  65       in
  66         Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
  67   where
  68     mkMap ::
  69       [(SignalId, SignalInfo)]
  70       -> SignalId
  71       -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
  72     mkMap sigmap id =
  73       if isPortSigUse $ sigUse info
  74         then
  75           let (decs, type_mark) = vhdl_ty ty in
  76           (decs, Just (mkVHDLId nm, type_mark))
  77         else
  78           (Monoid.mempty, Nothing)
  79       where
  80         info = Maybe.fromMaybe
  81           (error $ "Signal not found in the name map? This should not happen!")
  82           (lookup id sigmap)
  83         nm = Maybe.fromMaybe
  84           (error $ "Signal not named? This should not happen!")
  85           (sigName info)
  86         ty = sigTy info
  87
  88   -- | Create the VHDL AST for an entity
  89 createEntityAST ::
  90   HsFunction            -- | The signature of the function we're working with
  91   -> [VHDLSignalMap]    -- | The entity's arguments
  92   -> VHDLSignalMap      -- | The entity's result
  93   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  94
  95 createEntityAST hsfunc args res =
  96   AST.EntityDec vhdl_id ports
  97   where
  98     vhdl_id = mkEntityId hsfunc
  99     ports = concatMap (mapToPorts AST.In) args
 100             ++ mapToPorts AST.Out res
 101             ++ clk_port
 102     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 103     mapToPorts mode m =
 104       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 105     -- Add a clk port if we have state
 106     clk_port = if hasState hsfunc
 107       then
 108         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
 109       else
 110         []
 111
 112 -- | Create a port declaration
 113 mkIfaceSigDec ::
 114   AST.Mode                         -- | The mode for the port (In / Out)
 115   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 116   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 117
 118 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 119 mkIfaceSigDec _ Nothing = Nothing
 120
 121 -- | Generate a VHDL entity name for the given hsfunc
 122 mkEntityId hsfunc =
 123   -- TODO: This doesn't work for functions with multiple signatures!
 124   mkVHDLId $ hsFuncName hsfunc
 125
 126 -- | Create an architecture for a given function
 127 createArchitecture ::
 128   FuncMap           -- ^ The functions in the current session
 129   -> HsFunction     -- ^ The function signature
 130   -> FuncData       -- ^ The function data collected so far
 131   -> Maybe AST.ArchBody -- ^ The architecture for this function
 132
 133 createArchitecture funcs hsfunc fdata =
 134   case fdata ^. fdFlatFunc of
 135     -- Skip (builtin) functions without a FlatFunction
 136     Nothing -> fdata ^. fdArch
 137     -- Create an architecture for all other functions
 138     Just flatfunc ->
 139       let
 140         sigs = flat_sigs flatfunc
 141         args = flat_args flatfunc
 142         res  = flat_res  flatfunc
 143         defs = flat_defs flatfunc
 144         entity_id = Maybe.fromMaybe
 145                       (error $ "Building architecture without an entity? This should not happen!")
 146                       (getEntityId fdata)
 147         -- Create signal declarations for all signals that are not in args and
 148         -- res
 149         (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
 150         -- TODO: Unique ty_decls
 151         -- TODO: Store ty_decls somewhere
 152         -- Create concurrent statements for all signal definitions
 153         statements = zipWith (mkConcSm funcs sigs) defs [0..]
 154         procs = map mkStateProcSm (makeStatePairs flatfunc)
 155         procs' = map AST.CSPSm procs
 156       in
 157         Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 158
 159 -- | Looks up all pairs of old state, new state signals, together with
 160 --   the state id they represent.
 161 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 162 makeStatePairs flatfunc =
 163   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 164     | old_info <- map snd (flat_sigs flatfunc)
 165     , new_info <- map snd (flat_sigs flatfunc)
 166         -- old_info must be an old state (and, because of the next equality,
 167         -- new_info must be a new state).
 168         , Maybe.isJust $ oldStateId $ sigUse old_info
 169         -- And the state numbers must match
 170     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 171
 172     -- Replace the second tuple element with the corresponding SignalInfo
 173     --args_states = map (Arrow.second $ signalInfo sigs) args
 174 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 175 mkStateProcSm (num, old, new) =
 176   AST.ProcSm label [clk] [statement]
 177   where
 178     label       = mkVHDLId $ "state_" ++ (show num)
 179     clk         = mkVHDLId "clk"
 180     rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
 181     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 182     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 183     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 184     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 185
 186 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
 187 mkSigDec info =
 188   let use = sigUse info in
 189   if isInternalSigUse use || isStateSigUse use then
 190     let (ty_decls, type_mark) = vhdl_ty ty in
 191     (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
 192   else
 193     ([], Nothing)
 194   where
 195     ty = sigTy info
 196
 197 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 198 --   is not named.
 199 getSignalId :: SignalInfo -> AST.VHDLId
 200 getSignalId info =
 201     mkVHDLId $ Maybe.fromMaybe
 202       (error $ "Unnamed signal? This should not happen!")
 203       (sigName info)
 204
 205 -- | Transforms a signal definition into a VHDL concurrent statement
 206 mkConcSm ::
 207   FuncMap                  -- ^ The functions in the current session
 208   -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
 209   -> SigDef                -- ^ The signal definition
 210   -> Int                   -- ^ A number that will be unique for all
 211                            --   concurrent statements in the architecture.
 212   -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
 213
 214 mkConcSm funcs sigs (FApp hsfunc args res) num =
 215   let
 216     fdata_maybe = Map.lookup hsfunc funcs
 217     fdata = Maybe.fromMaybe
 218         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
 219         fdata_maybe
 220     entity = Maybe.fromMaybe
 221         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
 222         (fdata ^. fdEntity)
 223     entity_id = ent_id entity
 224     label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
 225     -- Add a clk port if we have state
 226     clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
 227     portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
 228   in
 229     AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 230
 231 mkConcSm _ sigs (UncondDef src dst) _ =
 232   let
 233     src_expr  = vhdl_expr src
 234     src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 235     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 236     assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 237   in
 238     AST.CSSASm assign
 239   where
 240     vhdl_expr (Left id) = mkIdExpr sigs id
 241     vhdl_expr (Right expr) =
 242       case expr of
 243         (EqLit id lit) ->
 244           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 245         (Literal lit) ->
 246           AST.PrimLit lit
 247         (Eq a b) ->
 248           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 249
 250 mkConcSm _ sigs (CondDef cond true false dst) _ =
 251   let
 252     cond_expr  = mkIdExpr sigs cond
 253     true_expr  = mkIdExpr sigs true
 254     false_expr  = mkIdExpr sigs false
 255     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 256     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 257     whenelse = AST.WhenElse true_wform cond_expr
 258     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 259     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 260   in
 261     AST.CSSASm assign
 262
 263 -- | Turn a SignalId into a VHDL Expr
 264 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 265 mkIdExpr sigs id =
 266   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 267   AST.PrimName src_name
 268
 269 mkAssocElems ::
 270   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 271   -> [SignalMap]                -- | The signals that are applied to function
 272   -> SignalMap                  -- | the signals in which to store the function result
 273   -> Entity                     -- | The entity to map against.
 274   -> [AST.AssocElem]            -- | The resulting port maps
 275
 276 mkAssocElems sigmap args res entity =
 277     -- Create the actual AssocElems
 278     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 279   where
 280     -- Turn the ports and signals from a map into a flat list. This works,
 281     -- since the maps must have an identical form by definition. TODO: Check
 282     -- the similar form?
 283     arg_ports = concat (map Foldable.toList (ent_args entity))
 284     res_ports = Foldable.toList (ent_res entity)
 285     arg_sigs  = (concat (map Foldable.toList args))
 286     res_sigs  = Foldable.toList res
 287     -- Extract the id part from the (id, type) tuple
 288     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 289     -- Translate signal numbers into names
 290     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 291
 292 -- | Look up a signal in the signal name map
 293 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 294 lookupSigName sigs sig = name
 295   where
 296     info = Maybe.fromMaybe
 297       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 298       (lookup sig sigs)
 299     name = Maybe.fromMaybe
 300       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 301       (sigName info)
 302
 303 -- | Create an VHDL port -> signal association
 304 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 305 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
 306 mkAssocElem Nothing _ = Nothing
 307
 308 -- | Extracts the generated entity id from the given funcdata
 309 getEntityId :: FuncData -> Maybe AST.VHDLId
 310 getEntityId fdata =
 311   case fdata ^. fdEntity of
 312     Nothing -> Nothing
 313     Just e  -> case ent_decl e of
 314       Nothing -> Nothing
 315       Just (AST.EntityDec id _) -> Just id
 316
 317 getLibraryUnits ::
 318   FuncData                    -- | A function from the session
 319   -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 320
 321 getLibraryUnits fdata =
 322   case fdata ^. fdEntity of
 323     Nothing -> []
 324     Just ent ->
 325       case ent_decl ent of
 326       Nothing -> []
 327       Just decl ->
 328         case fdata ^. fdArch of
 329           Nothing -> []
 330           Just arch ->
 331               [AST.LUEntity decl, AST.LUArch arch]
 332               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 333
 334 -- | The VHDL Bit type
 335 bit_ty :: AST.TypeMark
 336 bit_ty = AST.unsafeVHDLBasicId "Bit"
 337
 338 -- | The VHDL Boolean type
 339 bool_ty :: AST.TypeMark
 340 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 341
 342 -- | The VHDL std_logic
 343 std_logic_ty :: AST.TypeMark
 344 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 345
 346 -- Translate a Haskell type to a VHDL type
 347 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
 348 vhdl_ty ty = Maybe.fromMaybe
 349   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 350   (vhdl_ty_maybe ty)
 351
 352 -- Translate a Haskell type to a VHDL type, optionally generating a type
 353 -- declaration for the type.
 354 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 355 vhdl_ty_maybe ty =
 356   if Type.coreEqType ty TysWiredIn.boolTy
 357     then
 358       Just ([], bool_ty)
 359     else
 360       case Type.splitTyConApp_maybe ty of
 361         Just (tycon, args) ->
 362           let name = TyCon.tyConName tycon in
 363             -- TODO: Do something more robust than string matching
 364             case Name.getOccString name of
 365               "Bit"      -> Just ([], std_logic_ty)
 366               "FSVec"    ->
 367                 let
 368                   [len, el_ty] = args
 369                   -- TODO: Find actual number
 370                   ty_id = mkVHDLId ("vector_" ++ (show len))
 371                   -- TODO: Use el_ty
 372                   range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
 373                   ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 374                   ty_dec = AST.TypeDec ty_id ty_def
 375                 in
 376                   Just ([ty_dec], ty_id)
 377               otherwise  -> Nothing
 378         otherwise -> Nothing
 379
 380 -- Shortcut
 381 mkVHDLId :: String -> AST.VHDLId
 382 mkVHDLId s =
 383   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
 384   where
 385     -- Strip invalid characters.
 386     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 387     -- Strip multiple adjacent underscores
 388     strip_multiscore = concat . map (\cs ->
 389         case cs of
 390           ('_':_) -> "_"
 391           _ -> cs
 392       ) . List.group