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