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