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 builtin_funcs 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 ent_decl' = createEntityAST fname args' res'
 119       let AST.EntityDec entity_id _ = ent_decl'
 120       let signature = Entity entity_id args' res'
 121       modA vsSignatures (Map.insert (bndrToString fname) signature)
 122       return ent_decl'
 123   where
 124     mkMap ::
 125       --[(SignalId, SignalInfo)]
 126       CoreSyn.CoreBndr
 127       -> VHDLState VHDLSignalMapElement
 128     -- We only need the vsTypes element from the state
 129     mkMap = (\bndr ->
 130       let
 131         --info = Maybe.fromMaybe
 132         --  (error $ "Signal not found in the name map? This should not happen!")
 133         --  (lookup id sigmap)
 134         --  Assume the bndr has a valid VHDL id already
 135         id = bndrToVHDLId bndr
 136         ty = Var.varType bndr
 137       in
 138         if True -- isPortSigUse $ sigUse info
 139           then do
 140             type_mark <- vhdl_ty ty
 141             return $ Just (id, type_mark)
 142           else
 143             return $ Nothing
 144        )
 145
 146   -- | Create the VHDL AST for an entity
 147 createEntityAST ::
 148   CoreSyn.CoreBndr             -- | The name of the function
 149   -> [VHDLSignalMapElement]    -- | The entity's arguments
 150   -> VHDLSignalMapElement      -- | The entity's result
 151   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 152
 153 createEntityAST name args res =
 154   AST.EntityDec vhdl_id ports
 155   where
 156     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 157     vhdl_id = mkVHDLBasicId $ bndrToString name
 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 " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 194   --      (Map.lookup hsfunc signaturemap)
 195   let entity_id = mkVHDLBasicId $ bndrToString fname
 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 (bndrToString 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
 358 -- Create an unconditional assignment statement
 359 mkUncondAssign ::
 360   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
 361   -> AST.Expr -- ^ The expression to assign
 362   -> AST.ConcSm -- ^ The resulting concurrent statement
 363 mkUncondAssign dst expr = mkAssign dst Nothing expr
 364
 365 -- Create a conditional assignment statement
 366 mkCondAssign ::
 367   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
 368   -> AST.Expr -- ^ The condition
 369   -> AST.Expr -- ^ The value when true
 370   -> AST.Expr -- ^ The value when false
 371   -> AST.ConcSm -- ^ The resulting concurrent statement
 372 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
 373
 374 -- Create a conditional or unconditional assignment statement
 375 mkAssign ::
 376   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
 377   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
 378                                  -- and the value to assign when true.
 379   AST.Expr -> -- ^ The value to assign when false or no condition
 380   AST.ConcSm -- ^ The resulting concurrent statement
 381
 382 mkAssign dst cond false_expr =
 383   let
 384     -- I'm not 100% how this assignment AST works, but this gets us what we
 385     -- want...
 386     whenelse = case cond of
 387       Just (cond_expr, true_expr) ->
 388         let
 389           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 390         in
 391           [AST.WhenElse true_wform cond_expr]
 392       Nothing -> []
 393     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 394     dst_name  = case dst of
 395       Left bndr -> AST.NSimple (bndrToVHDLId bndr)
 396       Right name -> name
 397     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
 398   in
 399     AST.CSSASm assign
 400
 401 -- Create a record field selector that selects the given label from the record
 402 -- stored in the given binder.
 403 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
 404 mkSelectedName bndr label =
 405   let
 406     sel_prefix = AST.NSimple $ bndrToVHDLId bndr
 407     sel_suffix = AST.SSimple $ label
 408   in
 409     AST.NSelected $ sel_prefix AST.:.: sel_suffix
 410
 411 -- Finds the field labels for VHDL type generated for the given Core type,
 412 -- which must result in a record type.
 413 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
 414 getFieldLabels ty = do
 415   -- Ensure that the type is generated (but throw away it's VHDLId)
 416   vhdl_ty ty
 417   -- Get the types map, lookup and unpack the VHDL TypeDef
 418   types <- getA vsTypes
 419   case Map.lookup (OrdType ty) types of
 420     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 421     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 422
 423 -- Turn a variable reference into a AST expression
 424 varToVHDLExpr :: Var.Var -> AST.Expr
 425 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
 426
 427 -- Turn a constructor into an AST expression. For dataconstructors, this is
 428 -- only the constructor itself, not any arguments it has. Should not be called
 429 -- with a DEFAULT constructor.
 430 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 431 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
 432   where
 433     tycon = DataCon.dataConTyCon dc
 434     tyname = TyCon.tyConName tycon
 435     dcname = DataCon.dataConName dc
 436     lit = case Name.getOccString tyname of
 437       -- TODO: Do something more robust than string matching
 438       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 439       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 440 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 441 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 442
 443
 444
 445 {-
 446 mkConcSm sigs (UncondDef src dst) _ = do
 447   src_expr <- vhdl_expr src
 448   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 449   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 450   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 451   return $ AST.CSSASm assign
 452   where
 453     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 454     vhdl_expr (Right expr) =
 455       case expr of
 456         (EqLit id lit) ->
 457           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 458         (Literal lit Nothing) ->
 459           return $ AST.PrimLit lit
 460         (Literal lit (Just ty)) -> do
 461           -- Create a cast expression, which is just a function call using the
 462           -- type name as the function name.
 463           let litexpr = AST.PrimLit lit
 464           ty_id <- vhdl_ty ty
 465           let ty_name = AST.NSimple ty_id
 466           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 467           return $ AST.PrimFCall $ AST.FCall ty_name args
 468         (Eq a b) ->
 469          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 470
 471 mkConcSm sigs (CondDef cond true false dst) _ =
 472   let
 473     cond_expr  = mkIdExpr sigs cond
 474     true_expr  = mkIdExpr sigs true
 475     false_expr  = mkIdExpr sigs false
 476     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 477     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 478     whenelse = AST.WhenElse true_wform cond_expr
 479     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 480     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 481   in
 482     return $ AST.CSSASm assign
 483 -}
 484 -- | Turn a SignalId into a VHDL Expr
 485 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 486 mkIdExpr sigs id =
 487   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 488   AST.PrimName src_name
 489
 490 mkAssocElems ::
 491   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
 492   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 493   -> Entity                     -- | The entity to map against.
 494   -> [AST.AssocElem]            -- | The resulting port maps
 495
 496 mkAssocElems args res entity =
 497     -- Create the actual AssocElems
 498     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 499   where
 500     -- Turn the ports and signals from a map into a flat list. This works,
 501     -- since the maps must have an identical form by definition. TODO: Check
 502     -- the similar form?
 503     arg_ports = ent_args entity
 504     res_port  = ent_res entity
 505     -- Extract the id part from the (id, type) tuple
 506     ports     = map (Monad.liftM fst) (res_port : arg_ports)
 507     -- Translate signal numbers into names
 508     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
 509
 510 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 511 -- simple Var CoreExprs, not complexer ones.
 512 varBndr :: CoreSyn.CoreExpr -> Var.Id
 513 varBndr (CoreSyn.Var id) = id
 514
 515 -- | Look up a signal in the signal name map
 516 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 517 lookupSigName sigs sig = name
 518   where
 519     info = Maybe.fromMaybe
 520       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 521       (lookup sig sigs)
 522     name = Maybe.fromMaybe
 523       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 524       (sigName info)
 525
 526 -- | Create an VHDL port -> signal association
 527 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 528 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 529 mkAssocElem Nothing _ = Nothing
 530
 531 -- | The VHDL Bit type
 532 bit_ty :: AST.TypeMark
 533 bit_ty = AST.unsafeVHDLBasicId "Bit"
 534
 535 -- | The VHDL Boolean type
 536 bool_ty :: AST.TypeMark
 537 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 538
 539 -- | The VHDL std_logic
 540 std_logic_ty :: AST.TypeMark
 541 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 542
 543 -- Translate a Haskell type to a VHDL type
 544 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 545 vhdl_ty ty = do
 546   typemap <- getA vsTypes
 547   let builtin_ty = do -- See if this is a tycon and lookup its name
 548         (tycon, args) <- Type.splitTyConApp_maybe ty
 549         let name = Name.getOccString (TyCon.tyConName tycon)
 550         Map.lookup name builtin_types
 551   -- If not a builtin type, try the custom types
 552   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 553   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 554     -- Found a type, return it
 555     Just t -> return t
 556     -- No type yet, try to construct it
 557     Nothing -> do
 558       newty_maybe <- (construct_vhdl_ty ty)
 559       case newty_maybe of
 560         Just (ty_id, ty_def) -> do
 561           -- TODO: Check name uniqueness
 562           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 563           return ty_id
 564         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 565
 566 -- Construct a new VHDL type for the given Haskell type.
 567 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 568 construct_vhdl_ty ty = do
 569   case Type.splitTyConApp_maybe ty of
 570     Just (tycon, args) -> do
 571       let name = Name.getOccString (TyCon.tyConName tycon)
 572       case name of
 573         "TFVec" -> do
 574           res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) ty
 575           return $ Just $ (Arrow.second Right) res
 576         -- "SizedWord" -> do
 577         --   res <- mk_vector_ty (sized_word_len ty) ty
 578         --   return $ Just $ (Arrow.second Left) res
 579         "RangedWord" -> do
 580           res <- mk_natural_ty 0 (ranged_word_bound ty) ty
 581           return $ Just $ (Arrow.second Right) res
 582         -- Create a custom type from this tycon
 583         otherwise -> mk_tycon_ty tycon args
 584     Nothing -> return $ Nothing
 585
 586 -- | Create VHDL type for a custom tycon
 587 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 588 mk_tycon_ty tycon args =
 589   case TyCon.tyConDataCons tycon of
 590     -- Not an algebraic type
 591     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
 592     [dc] -> do
 593       let arg_tys = DataCon.dataConRepArgTys dc
 594       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 595       -- violation? Or does it only mean not to apply it again to the same
 596       -- subject?
 597       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 598       elem_tys <- mapM vhdl_ty real_arg_tys
 599       let elems = zipWith AST.ElementDec recordlabels elem_tys
 600       -- For a single construct datatype, build a record with one field for
 601       -- each argument.
 602       -- TODO: Add argument type ids to this, to ensure uniqueness
 603       -- TODO: Special handling for tuples?
 604       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 605       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 606       return $ Just (ty_id, Left ty_def)
 607     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
 608   where
 609     -- Create a subst that instantiates all types passed to the tycon
 610     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 611     -- to work so far, though..
 612     tyvars = TyCon.tyConTyVars tycon
 613     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 614
 615 -- | Create a VHDL vector type
 616 mk_vector_ty ::
 617   Int -- ^ The length of the vector
 618   -> Type.Type -- ^ The Haskell element type of the Vector
 619   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 620   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 621
 622 mk_vector_ty len el_ty ty = do
 623   elem_types_map <- getA vsElemTypes
 624   el_ty_tm <- vhdl_ty el_ty
 625   let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 626   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 627   let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
 628   case existing_elem_ty of
 629     Just t -> do
 630       let ty_def = AST.SubtypeIn t (Just range)
 631       return (ty_id, ty_def)
 632     Nothing -> do
 633       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 634       let vec_def = AST.TDA $ AST.UnconsArrayDef [naturalTM] el_ty_tm
 635       modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
 636       modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id))
 637       let ty_def = AST.SubtypeIn vec_id (Just range)
 638       return (ty_id, ty_def)
 639
 640 mk_natural_ty ::
 641   Int -- ^ The minimum bound (> 0)
 642   -> Int -- ^ The maximum bound (> minimum bound)
 643   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 644   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 645 mk_natural_ty min_bound max_bound ty = do
 646   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 647   let ty_def = AST.SubtypeIn naturalTM (Nothing)
 648   return (ty_id, ty_def)
 649
 650
 651 builtin_types =
 652   Map.fromList [
 653     ("Bit", std_logic_ty),
 654     ("Bool", bool_ty) -- TysWiredIn.boolTy
 655   ]
 656
 657 -- Shortcut for
 658 -- Can only contain alphanumerics and underscores. The supplied string must be
 659 -- a valid basic id, otherwise an error value is returned. This function is
 660 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 661 -- that.
 662 mkVHDLBasicId :: String -> AST.VHDLId
 663 mkVHDLBasicId s =
 664   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 665   where
 666     -- Strip invalid characters.
 667     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 668     -- Strip leading numbers and underscores
 669     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 670     -- Strip multiple adjacent underscores
 671     strip_multiscore = concat . map (\cs ->
 672         case cs of
 673           ('_':_) -> "_"
 674           _ -> cs
 675       ) . List.group
 676
 677 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 678 -- different characters than basic ids, but can never be used to refer to
 679 -- basic ids.
 680 -- Use extended Ids for any values that are taken from the source file.
 681 mkVHDLExtId :: String -> AST.VHDLId
 682 mkVHDLExtId s =
 683   AST.unsafeVHDLExtId $ strip_invalid s
 684   where
 685     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 686     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 687     strip_invalid = filter (`elem` allowed)
 688
 689 -- Creates a VHDL Id from a binder
 690 bndrToVHDLId ::
 691   CoreSyn.CoreBndr
 692   -> AST.VHDLId
 693
 694 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 695
 696 -- Extracts the binder name as a String
 697 bndrToString ::
 698   CoreSyn.CoreBndr
 699   -> String
 700
 701 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 702
 703 -- Extracts the string version of the name
 704 nameToString :: Name.Name -> String
 705 nameToString = OccName.occNameString . Name.nameOccName
 706
 707 -- | A consise representation of a (set of) ports on a builtin function
 708 --type PortMap = HsValueMap (String, AST.TypeMark)
 709 -- | A consise representation of a builtin function
 710 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
 711
 712 -- | Translate a list of concise representation of builtin functions to a
 713 --   SignatureMap
 714 mkBuiltins :: [BuiltIn] -> SignatureMap
 715 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 716     (name,
 717      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
 718   )
 719
 720 builtin_hsfuncs = Map.keys builtin_funcs
 721 builtin_funcs = mkBuiltins
 722   [
 723     BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 724     BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 725     BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 726     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
 727   ]
 728
 729 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 730
 731 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 732 --   a VHDLSignalMap
 733 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 734 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)