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