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