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