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