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