VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.Foldable as Foldable
   8 import qualified Data.List as List
   9 import qualified Data.Map as Map
  10 import qualified Maybe
  11 import qualified Control.Monad as Monad
  12 import qualified Control.Arrow as Arrow
  13 import qualified Control.Monad.Trans.State as State
  14 import qualified Data.Traversable as Traversable
  15 import qualified Data.Monoid as Monoid
  16 import Data.Accessor
  17 import qualified Data.Accessor.MonadState as MonadState
  18 import Text.Regex.Posix
  19 import Debug.Trace
  20
  21 -- ForSyDe
  22 import qualified ForSyDe.Backend.VHDL.AST as AST
  23
  24 -- GHC API
  25 import qualified Type
  26 import qualified Name
  27 import qualified OccName
  28 import qualified Var
  29 import qualified TyCon
  30 import qualified CoreSyn
  31 import Outputable ( showSDoc, ppr )
  32
  33 -- Local imports
  34 import VHDLTypes
  35 import Flatten
  36 import FlattenTypes
  37 import TranslatorTypes
  38 import HsValueMap
  39 import Pretty
  40 import CoreTools
  41 import Constants
  42 import Generate
  43 import GlobalNameTable
  44
  45 createDesignFiles ::
  46   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  47   -> [(AST.VHDLId, AST.DesignFile)]
  48
  49 createDesignFiles binds =
  50   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
  51   map (Arrow.second $ AST.DesignFile full_context) units
  52
  53   where
  54     init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
  55     (units, final_session) =
  56       State.runState (createLibraryUnits binds) init_session
  57     ty_decls = Map.elems (final_session ^. vsTypes)
  58     ieee_context = [
  59         AST.Library $ mkVHDLBasicId "IEEE",
  60         mkUseAll ["IEEE", "std_logic_1164"],
  61         mkUseAll ["IEEE", "numeric_std"]
  62       ]
  63     full_context =
  64       mkUseAll ["work", "types"]
  65       : ieee_context
  66     type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
  67
  68 -- Create a use foo.bar.all statement. Takes a list of components in the used
  69 -- name. Must contain at least two components
  70 mkUseAll :: [String] -> AST.ContextItem
  71 mkUseAll ss =
  72   AST.Use $ from AST.:.: AST.All
  73   where
  74     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  75     from = foldl select base_prefix (tail ss)
  76     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  77
  78 createLibraryUnits ::
  79   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  80   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  81
  82 createLibraryUnits binds = do
  83   entities <- Monad.mapM createEntity binds
  84   archs <- Monad.mapM createArchitecture binds
  85   return $ zipWith
  86     (\ent arch ->
  87       let AST.EntityDec id _ = ent in
  88       (id, [AST.LUEntity ent, AST.LUArch arch])
  89     )
  90     entities archs
  91
  92 -- | Create an entity for a given function
  93 createEntity ::
  94   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
  95   -> VHDLState AST.EntityDec -- | The resulting entity
  96
  97 createEntity (fname, expr) = do
  98       -- Strip off lambda's, these will be arguments
  99       let (args, letexpr) = CoreSyn.collectBinders expr
 100       args' <- Monad.mapM mkMap args
 101       -- There must be a let at top level
 102       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 103       res' <- mkMap res
 104       let ent_decl' = createEntityAST fname args' res'
 105       let AST.EntityDec entity_id _ = ent_decl'
 106       let signature = Entity entity_id args' res'
 107       modA vsSignatures (Map.insert (bndrToString fname) signature)
 108       return ent_decl'
 109   where
 110     mkMap ::
 111       --[(SignalId, SignalInfo)]
 112       CoreSyn.CoreBndr
 113       -> VHDLState VHDLSignalMapElement
 114     -- We only need the vsTypes element from the state
 115     mkMap = (\bndr ->
 116       let
 117         --info = Maybe.fromMaybe
 118         --  (error $ "Signal not found in the name map? This should not happen!")
 119         --  (lookup id sigmap)
 120         --  Assume the bndr has a valid VHDL id already
 121         id = bndrToVHDLId bndr
 122         ty = Var.varType bndr
 123       in
 124         if True -- isPortSigUse $ sigUse info
 125           then do
 126             type_mark <- vhdl_ty ty
 127             return $ Just (id, type_mark)
 128           else
 129             return $ Nothing
 130        )
 131
 132   -- | Create the VHDL AST for an entity
 133 createEntityAST ::
 134   CoreSyn.CoreBndr             -- | The name of the function
 135   -> [VHDLSignalMapElement]    -- | The entity's arguments
 136   -> VHDLSignalMapElement      -- | The entity's result
 137   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 138
 139 createEntityAST name args res =
 140   AST.EntityDec vhdl_id ports
 141   where
 142     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 143     vhdl_id = mkVHDLBasicId $ bndrToString name
 144     ports = Maybe.catMaybes $
 145               map (mkIfaceSigDec AST.In) args
 146               ++ [mkIfaceSigDec AST.Out res]
 147               ++ [clk_port]
 148     -- Add a clk port if we have state
 149     clk_port = if True -- hasState hsfunc
 150       then
 151         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
 152       else
 153         Nothing
 154
 155 -- | Create a port declaration
 156 mkIfaceSigDec ::
 157   AST.Mode                         -- | The mode for the port (In / Out)
 158   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 159   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 160
 161 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 162 mkIfaceSigDec _ Nothing = Nothing
 163
 164 -- | Generate a VHDL entity name for the given hsfunc
 165 mkEntityId hsfunc =
 166   -- TODO: This doesn't work for functions with multiple signatures!
 167   -- Use a Basic Id, since using extended id's for entities throws off
 168   -- precision and causes problems when generating filenames.
 169   mkVHDLBasicId $ hsFuncName hsfunc
 170
 171 -- | Create an architecture for a given function
 172 createArchitecture ::
 173   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 174   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 175
 176 createArchitecture (fname, expr) = do
 177   --signaturemap <- getA vsSignatures
 178   --let signature = Maybe.fromMaybe
 179   --      (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 180   --      (Map.lookup hsfunc signaturemap)
 181   let entity_id = mkVHDLBasicId $ bndrToString fname
 182   -- Strip off lambda's, these will be arguments
 183   let (args, letexpr) = CoreSyn.collectBinders expr
 184   -- There must be a let at top level
 185   let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
 186
 187   -- Create signal declarations for all internal and state signals
 188   sig_dec_maybes <- mapM (mkSigDec' . fst) binds
 189   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 190
 191   statements <- Monad.mapM mkConcSm binds
 192   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 193   where
 194     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
 195     procs' = map AST.CSPSm procs
 196     -- mkSigDec only uses vsTypes from the state
 197     mkSigDec' = mkSigDec
 198
 199 -- | Looks up all pairs of old state, new state signals, together with
 200 --   the state id they represent.
 201 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 202 makeStatePairs flatfunc =
 203   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 204     | old_info <- map snd (flat_sigs flatfunc)
 205     , new_info <- map snd (flat_sigs flatfunc)
 206         -- old_info must be an old state (and, because of the next equality,
 207         -- new_info must be a new state).
 208         , Maybe.isJust $ oldStateId $ sigUse old_info
 209         -- And the state numbers must match
 210     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 211
 212     -- Replace the second tuple element with the corresponding SignalInfo
 213     --args_states = map (Arrow.second $ signalInfo sigs) args
 214 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 215 mkStateProcSm (num, old, new) =
 216   AST.ProcSm label [clk] [statement]
 217   where
 218     label       = mkVHDLExtId $ "state_" ++ (show num)
 219     clk         = mkVHDLExtId "clk"
 220     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 221     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 222     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 223     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 224     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 225
 226 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 227 mkSigDec bndr =
 228   if True then do --isInternalSigUse use || isStateSigUse use then do
 229     type_mark <- vhdl_ty $ Var.varType bndr
 230     return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
 231   else
 232     return Nothing
 233
 234 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 235 --   is not named.
 236 getSignalId :: SignalInfo -> AST.VHDLId
 237 getSignalId info =
 238     mkVHDLExtId $ Maybe.fromMaybe
 239       (error $ "Unnamed signal? This should not happen!")
 240       (sigName info)
 241
 242 -- | Transforms a core binding into a VHDL concurrent statement
 243 mkConcSm ::
 244   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 245   -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 246
 247 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 248   signatures <- getA vsSignatures
 249   let
 250       (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 251       signature = Maybe.fromMaybe
 252           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
 253           (Map.lookup (bndrToString f) signatures)
 254       entity_id = ent_id signature
 255       label = bndrToString bndr
 256       -- Add a clk port if we have state
 257       --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 258       --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 259       portmaps = mkAssocElems args bndr signature
 260     in
 261       return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 262
 263 -- GHC generates some funny "r = r" bindings in let statements before
 264 -- simplification. This outputs some dummy ConcSM for these, so things will at
 265 -- least compile for now.
 266 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 267
 268 {-
 269 mkConcSm sigs (UncondDef src dst) _ = do
 270   src_expr <- vhdl_expr src
 271   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 272   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 273   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 274   return $ AST.CSSASm assign
 275   where
 276     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 277     vhdl_expr (Right expr) =
 278       case expr of
 279         (EqLit id lit) ->
 280           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 281         (Literal lit Nothing) ->
 282           return $ AST.PrimLit lit
 283         (Literal lit (Just ty)) -> do
 284           -- Create a cast expression, which is just a function call using the
 285           -- type name as the function name.
 286           let litexpr = AST.PrimLit lit
 287           ty_id <- vhdl_ty ty
 288           let ty_name = AST.NSimple ty_id
 289           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 290           return $ AST.PrimFCall $ AST.FCall ty_name args
 291         (Eq a b) ->
 292          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 293
 294 mkConcSm sigs (CondDef cond true false dst) _ =
 295   let
 296     cond_expr  = mkIdExpr sigs cond
 297     true_expr  = mkIdExpr sigs true
 298     false_expr  = mkIdExpr sigs false
 299     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 300     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 301     whenelse = AST.WhenElse true_wform cond_expr
 302     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 303     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 304   in
 305     return $ AST.CSSASm assign
 306 -}
 307 -- | Turn a SignalId into a VHDL Expr
 308 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 309 mkIdExpr sigs id =
 310   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 311   AST.PrimName src_name
 312
 313 mkAssocElems ::
 314   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
 315   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 316   -> Entity                     -- | The entity to map against.
 317   -> [AST.AssocElem]            -- | The resulting port maps
 318
 319 mkAssocElems args res entity =
 320     -- Create the actual AssocElems
 321     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 322   where
 323     -- Turn the ports and signals from a map into a flat list. This works,
 324     -- since the maps must have an identical form by definition. TODO: Check
 325     -- the similar form?
 326     arg_ports = ent_args entity
 327     res_port  = ent_res entity
 328     -- Extract the id part from the (id, type) tuple
 329     ports     = map (Monad.liftM fst) (res_port : arg_ports)
 330     -- Translate signal numbers into names
 331     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
 332
 333 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 334 -- simple Var CoreExprs, not complexer ones.
 335 varBndr :: CoreSyn.CoreExpr -> Var.Id
 336 varBndr (CoreSyn.Var id) = id
 337
 338 -- | Look up a signal in the signal name map
 339 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 340 lookupSigName sigs sig = name
 341   where
 342     info = Maybe.fromMaybe
 343       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 344       (lookup sig sigs)
 345     name = Maybe.fromMaybe
 346       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 347       (sigName info)
 348
 349 -- | Create an VHDL port -> signal association
 350 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 351 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 352 mkAssocElem Nothing _ = Nothing
 353
 354 -- | The VHDL Bit type
 355 bit_ty :: AST.TypeMark
 356 bit_ty = AST.unsafeVHDLBasicId "Bit"
 357
 358 -- | The VHDL Boolean type
 359 bool_ty :: AST.TypeMark
 360 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 361
 362 -- | The VHDL std_logic
 363 std_logic_ty :: AST.TypeMark
 364 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 365
 366 -- Translate a Haskell type to a VHDL type
 367 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 368 vhdl_ty ty = do
 369   typemap <- getA vsTypes
 370   let builtin_ty = do -- See if this is a tycon and lookup its name
 371         (tycon, args) <- Type.splitTyConApp_maybe ty
 372         let name = Name.getOccString (TyCon.tyConName tycon)
 373         Map.lookup name builtin_types
 374   -- If not a builtin type, try the custom types
 375   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 376   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 377     -- Found a type, return it
 378     Just t -> return t
 379     -- No type yet, try to construct it
 380     Nothing -> do
 381       let new_ty = do
 382             -- Use the Maybe Monad for failing when one of these fails
 383             (tycon, args) <- Type.splitTyConApp_maybe ty
 384             let name = Name.getOccString (TyCon.tyConName tycon)
 385             case name of
 386               "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
 387               "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
 388               otherwise -> Nothing
 389       -- Return new_ty when a new type was successfully created
 390       Maybe.fromMaybe
 391         (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 392         new_ty
 393
 394 -- | Create a VHDL vector type
 395 mk_vector_ty ::
 396   Int -- ^ The length of the vector
 397   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 398   -> VHDLState AST.TypeMark -- The typemark created.
 399
 400 mk_vector_ty len ty = do
 401   -- Assume there is a single type argument
 402   let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
 403   -- TODO: Use el_ty
 404   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 405   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 406   let ty_dec = AST.TypeDec ty_id ty_def
 407   -- TODO: Check name uniqueness
 408   --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
 409   modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
 410   modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
 411   return ty_id
 412
 413
 414 builtin_types =
 415   Map.fromList [
 416     ("Bit", std_logic_ty),
 417     ("Bool", bool_ty) -- TysWiredIn.boolTy
 418   ]
 419
 420 -- Shortcut for
 421 -- Can only contain alphanumerics and underscores. The supplied string must be
 422 -- a valid basic id, otherwise an error value is returned. This function is
 423 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 424 -- that.
 425 mkVHDLBasicId :: String -> AST.VHDLId
 426 mkVHDLBasicId s =
 427   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 428   where
 429     -- Strip invalid characters.
 430     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 431     -- Strip leading numbers and underscores
 432     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 433     -- Strip multiple adjacent underscores
 434     strip_multiscore = concat . map (\cs ->
 435         case cs of
 436           ('_':_) -> "_"
 437           _ -> cs
 438       ) . List.group
 439
 440 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 441 -- different characters than basic ids, but can never be used to refer to
 442 -- basic ids.
 443 -- Use extended Ids for any values that are taken from the source file.
 444 mkVHDLExtId :: String -> AST.VHDLId
 445 mkVHDLExtId s =
 446   AST.unsafeVHDLExtId $ strip_invalid s
 447   where
 448     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 449     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 450     strip_invalid = filter (`elem` allowed)
 451
 452 -- Creates a VHDL Id from a binder
 453 bndrToVHDLId ::
 454   CoreSyn.CoreBndr
 455   -> AST.VHDLId
 456
 457 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 458
 459 -- Extracts the binder name as a String
 460 bndrToString ::
 461   CoreSyn.CoreBndr
 462   -> String
 463
 464 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 465
 466 -- | A consise representation of a (set of) ports on a builtin function
 467 --type PortMap = HsValueMap (String, AST.TypeMark)
 468 -- | A consise representation of a builtin function
 469 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
 470
 471 -- | Translate a list of concise representation of builtin functions to a
 472 --   SignatureMap
 473 mkBuiltins :: [BuiltIn] -> SignatureMap
 474 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 475     (name,
 476      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
 477   )
 478
 479 builtin_hsfuncs = Map.keys builtin_funcs
 480 builtin_funcs = mkBuiltins
 481   [
 482     BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 483     BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 484     BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 485     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
 486   ]
 487
 488 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 489 --   a VHDLSignalMap
 490 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 491 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)