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