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 Maybe
   8 import qualified Control.Monad as Monad
   9 import qualified Control.Arrow as Arrow
  10 import qualified Data.Traversable as Traversable
  11 import qualified Data.Monoid as Monoid
  12
  13 import qualified Type
  14 import qualified TysWiredIn
  15 import qualified Name
  16 import qualified TyCon
  17 import Outputable ( showSDoc, ppr )
  18
  19 import qualified ForSyDe.Backend.VHDL.AST as AST
  20
  21 import VHDLTypes
  22 import Flatten
  23 import FlattenTypes
  24 import TranslatorTypes
  25 import Pretty
  26
  27 getDesignFiles :: VHDLState [AST.DesignFile]
  28 getDesignFiles = do
  29   -- Extract the library units generated from all the functions in the
  30   -- session.
  31   funcs <- getFuncs
  32   let units = Maybe.mapMaybe getLibraryUnits funcs
  33   let context = [
  34         AST.Library $ mkVHDLId "IEEE",
  35         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
  36   return $ map (AST.DesignFile context) units
  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   -> VHDLState ()
  43
  44 createEntity hsfunc fdata =
  45   let func = flatFunc fdata in
  46   case func of
  47     -- Skip (builtin) functions without a FlatFunction
  48     Nothing -> do return ()
  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         entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
  65       in do
  66         setEntity hsfunc entity'
  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   HsFunction        -- | The function signature
 129   -> FuncData       -- | The function data collected so far
 130   -> VHDLState ()
 131
 132 createArchitecture hsfunc fdata =
 133   let func = flatFunc fdata in
 134   case func of
 135     -- Skip (builtin) functions without a FlatFunction
 136     Nothing -> do return ()
 137     -- Create an architecture for all other functions
 138     Just flatfunc -> do
 139       let sigs = flat_sigs flatfunc
 140       let args = flat_args flatfunc
 141       let res  = flat_res  flatfunc
 142       let defs = flat_defs flatfunc
 143       let entity_id = Maybe.fromMaybe
 144                       (error $ "Building architecture without an entity? This should not happen!")
 145                       (getEntityId fdata)
 146       -- Create signal declarations for all signals that are not in args and
 147       -- res
 148       let (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
 149       -- TODO: Unique ty_decls
 150       -- TODO: Store ty_decls somewhere
 151       -- Create concurrent statements for all signal definitions
 152       statements <- mapM (mkConcSm sigs) defs
 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   [(SignalId, SignalInfo)] -- | The signals in the current architecture
 207   -> SigDef                -- | The signal definition
 208   -> VHDLState AST.ConcSm    -- | The corresponding VHDL component instantiation.
 209
 210 mkConcSm sigs (FApp hsfunc args res) = do
 211   fdata_maybe <- getFunc hsfunc
 212   let fdata = Maybe.fromMaybe
 213         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
 214         fdata_maybe
 215   let entity = Maybe.fromMaybe
 216         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
 217         (funcEntity fdata)
 218   let entity_id = ent_id entity
 219   label <- uniqueName (AST.fromVHDLId entity_id)
 220   -- Add a clk port if we have state
 221   let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
 222   let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
 223   return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 224
 225 mkConcSm sigs (UncondDef src dst) = do
 226   let src_expr  = vhdl_expr src
 227   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 228   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 229   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 230   return $ AST.CSSASm assign
 231   where
 232     vhdl_expr (Left id) = mkIdExpr sigs id
 233     vhdl_expr (Right expr) =
 234       case expr of
 235         (EqLit id lit) ->
 236           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 237         (Literal lit) ->
 238           AST.PrimLit lit
 239         (Eq a b) ->
 240           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 241
 242 mkConcSm sigs (CondDef cond true false dst) = do
 243   let cond_expr  = mkIdExpr sigs cond
 244   let true_expr  = mkIdExpr sigs true
 245   let false_expr  = mkIdExpr sigs false
 246   let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 247   let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 248   let whenelse = AST.WhenElse true_wform cond_expr
 249   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 250   let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 251   return $ AST.CSSASm assign
 252
 253 -- | Turn a SignalId into a VHDL Expr
 254 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 255 mkIdExpr sigs id =
 256   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 257   AST.PrimName src_name
 258
 259 mkAssocElems ::
 260   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 261   -> [SignalMap]                -- | The signals that are applied to function
 262   -> SignalMap                  -- | the signals in which to store the function result
 263   -> Entity                     -- | The entity to map against.
 264   -> [AST.AssocElem]            -- | The resulting port maps
 265
 266 mkAssocElems sigmap args res entity =
 267     -- Create the actual AssocElems
 268     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 269   where
 270     -- Turn the ports and signals from a map into a flat list. This works,
 271     -- since the maps must have an identical form by definition. TODO: Check
 272     -- the similar form?
 273     arg_ports = concat (map Foldable.toList (ent_args entity))
 274     res_ports = Foldable.toList (ent_res entity)
 275     arg_sigs  = (concat (map Foldable.toList args))
 276     res_sigs  = Foldable.toList res
 277     -- Extract the id part from the (id, type) tuple
 278     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 279     -- Translate signal numbers into names
 280     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 281
 282 -- | Look up a signal in the signal name map
 283 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 284 lookupSigName sigs sig = name
 285   where
 286     info = Maybe.fromMaybe
 287       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 288       (lookup sig sigs)
 289     name = Maybe.fromMaybe
 290       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 291       (sigName info)
 292
 293 -- | Create an VHDL port -> signal association
 294 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 295 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
 296 mkAssocElem Nothing _ = Nothing
 297
 298 -- | Extracts the generated entity id from the given funcdata
 299 getEntityId :: FuncData -> Maybe AST.VHDLId
 300 getEntityId fdata =
 301   case funcEntity fdata of
 302     Nothing -> Nothing
 303     Just e  -> case ent_decl e of
 304       Nothing -> Nothing
 305       Just (AST.EntityDec id _) -> Just id
 306
 307 getLibraryUnits ::
 308   (HsFunction, FuncData)      -- | A function from the session
 309   -> Maybe [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 310
 311 getLibraryUnits (hsfunc, fdata) =
 312   case funcEntity fdata of
 313     Nothing -> Nothing
 314     Just ent ->
 315       case ent_decl ent of
 316       Nothing -> Nothing
 317       Just decl ->
 318         case funcArch fdata of
 319           Nothing -> Nothing
 320           Just arch ->
 321             Just $
 322               [AST.LUEntity decl, AST.LUArch arch]
 323               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 324
 325 -- | The VHDL Bit type
 326 bit_ty :: AST.TypeMark
 327 bit_ty = AST.unsafeVHDLBasicId "Bit"
 328
 329 -- | The VHDL Boolean type
 330 bool_ty :: AST.TypeMark
 331 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 332
 333 -- | The VHDL std_logic
 334 std_logic_ty :: AST.TypeMark
 335 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 336
 337 -- Translate a Haskell type to a VHDL type
 338 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
 339 vhdl_ty ty = Maybe.fromMaybe
 340   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 341   (vhdl_ty_maybe ty)
 342
 343 -- Translate a Haskell type to a VHDL type, optionally generating a type
 344 -- declaration for the type.
 345 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 346 vhdl_ty_maybe ty =
 347   if Type.coreEqType ty TysWiredIn.boolTy
 348     then
 349       Just ([], bool_ty)
 350     else
 351       case Type.splitTyConApp_maybe ty of
 352         Just (tycon, args) ->
 353           let name = TyCon.tyConName tycon in
 354             -- TODO: Do something more robust than string matching
 355             case Name.getOccString name of
 356               "Bit"      -> Just ([], std_logic_ty)
 357               "FSVec"    ->
 358                 let
 359                   [len, el_ty] = args
 360                   -- TODO: Find actual number
 361                   ty_id = mkVHDLId ("vector_" ++ (show len))
 362                   -- TODO: Use el_ty
 363                   range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
 364                   ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 365                   ty_dec = AST.TypeDec ty_id ty_def
 366                 in
 367                   Just ([ty_dec], ty_id)
 368               otherwise  -> Nothing
 369         otherwise -> Nothing
 370
 371 -- Shortcut
 372 mkVHDLId :: String -> AST.VHDLId
 373 mkVHDLId s =
 374   AST.unsafeVHDLBasicId s'
 375   where
 376     -- Strip invalid characters.
 377     s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s