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