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