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