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