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