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 Maybe
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Arrow as Arrow
  11 import qualified Data.Traversable as Traversable
  12 import qualified Data.Monoid as Monoid
  13
  14 import qualified Type
  15 import qualified TysWiredIn
  16 import qualified Name
  17 import qualified TyCon
  18 import Outputable ( showSDoc, ppr )
  19
  20 import qualified ForSyDe.Backend.VHDL.AST as AST
  21
  22 import VHDLTypes
  23 import Flatten
  24 import FlattenTypes
  25 import TranslatorTypes
  26 import Pretty
  27
  28 getDesignFiles :: VHDLState [AST.DesignFile]
  29 getDesignFiles = do
  30   -- Extract the library units generated from all the functions in the
  31   -- session.
  32   funcs <- getFuncs
  33   let units = Maybe.mapMaybe getLibraryUnits funcs
  34   let context = [
  35         AST.Library $ mkVHDLId "IEEE",
  36         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
  37   return $ map (AST.DesignFile context) units
  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   -> VHDLState ()
  44
  45 createEntity hsfunc fdata =
  46   let func = flatFunc fdata in
  47   case func of
  48     -- Skip (builtin) functions without a FlatFunction
  49     Nothing -> do return ()
  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         entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
  66       in do
  67         setEntity hsfunc entity'
  68   where
  69     mkMap ::
  70       [(SignalId, SignalInfo)]
  71       -> SignalId
  72       -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
  73     mkMap sigmap id =
  74       if isPortSigUse $ sigUse info
  75         then
  76           let (decs, type_mark) = vhdl_ty ty in
  77           (decs, Just (mkVHDLId nm, type_mark))
  78         else
  79           (Monoid.mempty, Nothing)
  80       where
  81         info = Maybe.fromMaybe
  82           (error $ "Signal not found in the name map? This should not happen!")
  83           (lookup id sigmap)
  84         nm = Maybe.fromMaybe
  85           (error $ "Signal not named? This should not happen!")
  86           (sigName info)
  87         ty = sigTy info
  88
  89   -- | Create the VHDL AST for an entity
  90 createEntityAST ::
  91   HsFunction            -- | The signature of the function we're working with
  92   -> [VHDLSignalMap]    -- | The entity's arguments
  93   -> VHDLSignalMap      -- | The entity's result
  94   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
  95
  96 createEntityAST hsfunc args res =
  97   AST.EntityDec vhdl_id ports
  98   where
  99     vhdl_id = mkEntityId hsfunc
 100     ports = concatMap (mapToPorts AST.In) args
 101             ++ mapToPorts AST.Out res
 102             ++ clk_port
 103     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 104     mapToPorts mode m =
 105       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 106     -- Add a clk port if we have state
 107     clk_port = if hasState hsfunc
 108       then
 109         [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
 110       else
 111         []
 112
 113 -- | Create a port declaration
 114 mkIfaceSigDec ::
 115   AST.Mode                         -- | The mode for the port (In / Out)
 116   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 117   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 118
 119 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 120 mkIfaceSigDec _ Nothing = Nothing
 121
 122 -- | Generate a VHDL entity name for the given hsfunc
 123 mkEntityId hsfunc =
 124   -- TODO: This doesn't work for functions with multiple signatures!
 125   mkVHDLId $ hsFuncName hsfunc
 126
 127 -- | Create an architecture for a given function
 128 createArchitecture ::
 129   HsFunction        -- | The function signature
 130   -> FuncData       -- | The function data collected so far
 131   -> VHDLState ()
 132
 133 createArchitecture hsfunc fdata =
 134   let func = flatFunc fdata in
 135   case func of
 136     -- Skip (builtin) functions without a FlatFunction
 137     Nothing -> do return ()
 138     -- Create an architecture for all other functions
 139     Just flatfunc -> do
 140       let sigs = flat_sigs flatfunc
 141       let args = flat_args flatfunc
 142       let res  = flat_res  flatfunc
 143       let defs = flat_defs flatfunc
 144       let 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       let (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 <- mapM (mkConcSm sigs) defs
 154       let procs = map mkStateProcSm (makeStatePairs flatfunc)
 155       let procs' = map AST.CSPSm procs
 156       let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 157       setArchitecture hsfunc arch
 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   [(SignalId, SignalInfo)] -- | The signals in the current architecture
 208   -> SigDef                -- | The signal definition
 209   -> VHDLState AST.ConcSm    -- | The corresponding VHDL component instantiation.
 210
 211 mkConcSm sigs (FApp hsfunc args res) = do
 212   fdata_maybe <- getFunc hsfunc
 213   let fdata = Maybe.fromMaybe
 214         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
 215         fdata_maybe
 216   let entity = Maybe.fromMaybe
 217         (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
 218         (funcEntity fdata)
 219   let entity_id = ent_id entity
 220   label <- uniqueName (AST.fromVHDLId entity_id)
 221   -- Add a clk port if we have state
 222   let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
 223   let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
 224   return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 225
 226 mkConcSm sigs (UncondDef src dst) = do
 227   let src_expr  = vhdl_expr src
 228   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 229   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 230   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 231   return $ AST.CSSASm assign
 232   where
 233     vhdl_expr (Left id) = mkIdExpr sigs id
 234     vhdl_expr (Right expr) =
 235       case expr of
 236         (EqLit id lit) ->
 237           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 238         (Literal lit) ->
 239           AST.PrimLit lit
 240         (Eq a b) ->
 241           (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 242
 243 mkConcSm sigs (CondDef cond true false dst) = do
 244   let cond_expr  = mkIdExpr sigs cond
 245   let true_expr  = mkIdExpr sigs true
 246   let false_expr  = mkIdExpr sigs false
 247   let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 248   let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 249   let whenelse = AST.WhenElse true_wform cond_expr
 250   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 251   let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 252   return $ AST.CSSASm assign
 253
 254 -- | Turn a SignalId into a VHDL Expr
 255 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 256 mkIdExpr sigs id =
 257   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 258   AST.PrimName src_name
 259
 260 mkAssocElems ::
 261   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 262   -> [SignalMap]                -- | The signals that are applied to function
 263   -> SignalMap                  -- | the signals in which to store the function result
 264   -> Entity                     -- | The entity to map against.
 265   -> [AST.AssocElem]            -- | The resulting port maps
 266
 267 mkAssocElems sigmap args res entity =
 268     -- Create the actual AssocElems
 269     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 270   where
 271     -- Turn the ports and signals from a map into a flat list. This works,
 272     -- since the maps must have an identical form by definition. TODO: Check
 273     -- the similar form?
 274     arg_ports = concat (map Foldable.toList (ent_args entity))
 275     res_ports = Foldable.toList (ent_res entity)
 276     arg_sigs  = (concat (map Foldable.toList args))
 277     res_sigs  = Foldable.toList res
 278     -- Extract the id part from the (id, type) tuple
 279     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 280     -- Translate signal numbers into names
 281     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 282
 283 -- | Look up a signal in the signal name map
 284 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 285 lookupSigName sigs sig = name
 286   where
 287     info = Maybe.fromMaybe
 288       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 289       (lookup sig sigs)
 290     name = Maybe.fromMaybe
 291       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 292       (sigName info)
 293
 294 -- | Create an VHDL port -> signal association
 295 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 296 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
 297 mkAssocElem Nothing _ = Nothing
 298
 299 -- | Extracts the generated entity id from the given funcdata
 300 getEntityId :: FuncData -> Maybe AST.VHDLId
 301 getEntityId fdata =
 302   case funcEntity fdata of
 303     Nothing -> Nothing
 304     Just e  -> case ent_decl e of
 305       Nothing -> Nothing
 306       Just (AST.EntityDec id _) -> Just id
 307
 308 getLibraryUnits ::
 309   (HsFunction, FuncData)      -- | A function from the session
 310   -> Maybe [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
 311
 312 getLibraryUnits (hsfunc, fdata) =
 313   case funcEntity fdata of
 314     Nothing -> Nothing
 315     Just ent ->
 316       case ent_decl ent of
 317       Nothing -> Nothing
 318       Just decl ->
 319         case funcArch fdata of
 320           Nothing -> Nothing
 321           Just arch ->
 322             Just $
 323               [AST.LUEntity decl, AST.LUArch arch]
 324               ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
 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 -> ([AST.TypeDec], AST.TypeMark)
 340 vhdl_ty ty = Maybe.fromMaybe
 341   (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 342   (vhdl_ty_maybe ty)
 343
 344 -- Translate a Haskell type to a VHDL type, optionally generating a type
 345 -- declaration for the type.
 346 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
 347 vhdl_ty_maybe ty =
 348   if Type.coreEqType ty TysWiredIn.boolTy
 349     then
 350       Just ([], bool_ty)
 351     else
 352       case Type.splitTyConApp_maybe ty of
 353         Just (tycon, args) ->
 354           let name = TyCon.tyConName tycon in
 355             -- TODO: Do something more robust than string matching
 356             case Name.getOccString name of
 357               "Bit"      -> Just ([], std_logic_ty)
 358               "FSVec"    ->
 359                 let
 360                   [len, el_ty] = args
 361                   -- TODO: Find actual number
 362                   ty_id = mkVHDLId ("vector_" ++ (show len))
 363                   -- TODO: Use el_ty
 364                   range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
 365                   ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 366                   ty_dec = AST.TypeDec ty_id ty_def
 367                 in
 368                   Just ([ty_dec], ty_id)
 369               otherwise  -> Nothing
 370         otherwise -> Nothing
 371
 372 -- Shortcut
 373 mkVHDLId :: String -> AST.VHDLId
 374 mkVHDLId s =
 375   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
 376   where
 377     -- Strip invalid characters.
 378     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 379     -- Strip multiple adjacent underscores
 380     strip_multiscore = concat . map (\cs ->
 381         case cs of
 382           ('_':_) -> "_"
 383           _ -> cs
 384       ) . List.group