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 builtin
 283       -- functions.
 284       funSignatures <- getA vsNameTable
 285       case (Map.lookup (bndrToString f) funSignatures) of
 286         Just (arg_count, builder) ->
 287           if length args == arg_count then
 288             let
 289               sigs = map (bndrToString.varBndr) args
 290               sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
 291               func = builder sigsNames
 292               src_wform = AST.Wform [AST.WformElem func Nothing]
 293               dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
 294               assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 295             in
 296               return $ AST.CSSASm assign
 297           else
 298             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString args
 299         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
 300     IdInfo.NotGlobalId -> do
 301       signatures <- getA vsSignatures
 302       -- This is a local id, so it should be a function whose definition we
 303       -- have and which can be turned into a component instantiation.
 304       let
 305         signature = Maybe.fromMaybe
 306           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
 307           (Map.lookup (bndrToString f) signatures)
 308         entity_id = ent_id signature
 309         label = bndrToString bndr
 310         -- Add a clk port if we have state
 311         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 312         --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 313         portmaps = mkAssocElems args bndr signature
 314         in
 315           return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 316     details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 317
 318 -- GHC generates some funny "r = r" bindings in let statements before
 319 -- simplification. This outputs some dummy ConcSM for these, so things will at
 320 -- least compile for now.
 321 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 322
 323 -- A single alt case must be a selector. This means thee scrutinee is a simple
 324 -- variable, the alternative is a dataalt with a single non-wild binder that
 325 -- is also returned.
 326 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 327   case alt of
 328     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 329       case List.elemIndex sel_bndr bndrs of
 330         Just i -> do
 331           labels <- getFieldLabels (Id.idType scrut)
 332           let label = labels!!i
 333           let sel_name = mkSelectedName scrut label
 334           let sel_expr = AST.PrimName sel_name
 335           return $ mkUncondAssign (Left bndr) sel_expr
 336         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 337
 338     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 339
 340 -- Multiple case alt are be conditional assignments and have only wild
 341 -- binders in the alts and only variables in the case values and a variable
 342 -- for a scrutinee. We check the constructor of the second alt, since the
 343 -- first is the default case, if there is any.
 344 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 345   let
 346     cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
 347     true_expr  = (varToVHDLExpr true)
 348     false_expr  = (varToVHDLExpr false)
 349   in
 350     return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
 351 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 352 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 353 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 354
 355 -- Create an unconditional assignment statement
 356 mkUncondAssign ::
 357   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
 358   -> AST.Expr -- ^ The expression to assign
 359   -> AST.ConcSm -- ^ The resulting concurrent statement
 360 mkUncondAssign dst expr = mkAssign dst Nothing expr
 361
 362 -- Create a conditional assignment statement
 363 mkCondAssign ::
 364   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
 365   -> AST.Expr -- ^ The condition
 366   -> AST.Expr -- ^ The value when true
 367   -> AST.Expr -- ^ The value when false
 368   -> AST.ConcSm -- ^ The resulting concurrent statement
 369 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
 370
 371 -- Create a conditional or unconditional assignment statement
 372 mkAssign ::
 373   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
 374   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
 375                                  -- and the value to assign when true.
 376   AST.Expr -> -- ^ The value to assign when false or no condition
 377   AST.ConcSm -- ^ The resulting concurrent statement
 378
 379 mkAssign dst cond false_expr =
 380   let
 381     -- I'm not 100% how this assignment AST works, but this gets us what we
 382     -- want...
 383     whenelse = case cond of
 384       Just (cond_expr, true_expr) ->
 385         let
 386           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 387         in
 388           [AST.WhenElse true_wform cond_expr]
 389       Nothing -> []
 390     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 391     dst_name  = case dst of
 392       Left bndr -> AST.NSimple (bndrToVHDLId bndr)
 393       Right name -> name
 394     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
 395   in
 396     AST.CSSASm assign
 397
 398 -- Create a record field selector that selects the given label from the record
 399 -- stored in the given binder.
 400 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
 401 mkSelectedName bndr label =
 402   let
 403     sel_prefix = AST.NSimple $ bndrToVHDLId bndr
 404     sel_suffix = AST.SSimple $ label
 405   in
 406     AST.NSelected $ sel_prefix AST.:.: sel_suffix
 407
 408 -- Finds the field labels for VHDL type generated for the given Core type,
 409 -- which must result in a record type.
 410 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
 411 getFieldLabels ty = do
 412   -- Ensure that the type is generated (but throw away it's VHDLId)
 413   vhdl_ty ty
 414   -- Get the types map, lookup and unpack the VHDL TypeDef
 415   types <- getA vsTypes
 416   case Map.lookup (OrdType ty) types of
 417     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 418     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 419
 420 -- Turn a variable reference into a AST expression
 421 varToVHDLExpr :: Var.Var -> AST.Expr
 422 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
 423
 424 -- Turn a constructor into an AST expression. For dataconstructors, this is
 425 -- only the constructor itself, not any arguments it has. Should not be called
 426 -- with a DEFAULT constructor.
 427 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 428 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
 429   where
 430     tycon = DataCon.dataConTyCon dc
 431     tyname = TyCon.tyConName tycon
 432     dcname = DataCon.dataConName dc
 433     lit = case Name.getOccString tyname of
 434       -- TODO: Do something more robust than string matching
 435       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 436       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 437 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 438 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 439
 440
 441
 442 {-
 443 mkConcSm sigs (UncondDef src dst) _ = do
 444   src_expr <- vhdl_expr src
 445   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 446   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 447   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 448   return $ AST.CSSASm assign
 449   where
 450     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 451     vhdl_expr (Right expr) =
 452       case expr of
 453         (EqLit id lit) ->
 454           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 455         (Literal lit Nothing) ->
 456           return $ AST.PrimLit lit
 457         (Literal lit (Just ty)) -> do
 458           -- Create a cast expression, which is just a function call using the
 459           -- type name as the function name.
 460           let litexpr = AST.PrimLit lit
 461           ty_id <- vhdl_ty ty
 462           let ty_name = AST.NSimple ty_id
 463           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 464           return $ AST.PrimFCall $ AST.FCall ty_name args
 465         (Eq a b) ->
 466          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 467
 468 mkConcSm sigs (CondDef cond true false dst) _ =
 469   let
 470     cond_expr  = mkIdExpr sigs cond
 471     true_expr  = mkIdExpr sigs true
 472     false_expr  = mkIdExpr sigs false
 473     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 474     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 475     whenelse = AST.WhenElse true_wform cond_expr
 476     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 477     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 478   in
 479     return $ AST.CSSASm assign
 480 -}
 481 -- | Turn a SignalId into a VHDL Expr
 482 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 483 mkIdExpr sigs id =
 484   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 485   AST.PrimName src_name
 486
 487 mkAssocElems ::
 488   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
 489   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 490   -> Entity                     -- | The entity to map against.
 491   -> [AST.AssocElem]            -- | The resulting port maps
 492
 493 mkAssocElems args res entity =
 494     -- Create the actual AssocElems
 495     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 496   where
 497     -- Turn the ports and signals from a map into a flat list. This works,
 498     -- since the maps must have an identical form by definition. TODO: Check
 499     -- the similar form?
 500     arg_ports = ent_args entity
 501     res_port  = ent_res entity
 502     -- Extract the id part from the (id, type) tuple
 503     ports     = map (Monad.liftM fst) (res_port : arg_ports)
 504     -- Translate signal numbers into names
 505     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
 506
 507 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 508 -- simple Var CoreExprs, not complexer ones.
 509 varBndr :: CoreSyn.CoreExpr -> Var.Id
 510 varBndr (CoreSyn.Var id) = id
 511
 512 -- | Look up a signal in the signal name map
 513 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 514 lookupSigName sigs sig = name
 515   where
 516     info = Maybe.fromMaybe
 517       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 518       (lookup sig sigs)
 519     name = Maybe.fromMaybe
 520       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 521       (sigName info)
 522
 523 -- | Create an VHDL port -> signal association
 524 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 525 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 526 mkAssocElem Nothing _ = Nothing
 527
 528 -- | The VHDL Bit type
 529 bit_ty :: AST.TypeMark
 530 bit_ty = AST.unsafeVHDLBasicId "Bit"
 531
 532 -- | The VHDL Boolean type
 533 bool_ty :: AST.TypeMark
 534 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 535
 536 -- | The VHDL std_logic
 537 std_logic_ty :: AST.TypeMark
 538 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 539
 540 -- Translate a Haskell type to a VHDL type
 541 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 542 vhdl_ty ty = do
 543   typemap <- getA vsTypes
 544   let builtin_ty = do -- See if this is a tycon and lookup its name
 545         (tycon, args) <- Type.splitTyConApp_maybe ty
 546         let name = Name.getOccString (TyCon.tyConName tycon)
 547         Map.lookup name builtin_types
 548   -- If not a builtin type, try the custom types
 549   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 550   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 551     -- Found a type, return it
 552     Just t -> return t
 553     -- No type yet, try to construct it
 554     Nothing -> do
 555       newty_maybe <- (construct_vhdl_ty ty)
 556       case newty_maybe of
 557         Just (ty_id, ty_def) -> do
 558           -- TODO: Check name uniqueness
 559           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 560           return ty_id
 561         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 562
 563 -- Construct a new VHDL type for the given Haskell type.
 564 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 565 construct_vhdl_ty ty = do
 566   case Type.splitTyConApp_maybe ty of
 567     Just (tycon, args) -> do
 568       let name = Name.getOccString (TyCon.tyConName tycon)
 569       case name of
 570         "TFVec" -> do
 571           res <- mk_vector_ty (tfvec_len ty) ty
 572           return $ Just $ (Arrow.second Left) res
 573         "SizedWord" -> do
 574           res <- mk_vector_ty (sized_word_len ty) ty
 575           return $ Just $ (Arrow.second Left) res
 576         "RangedWord" -> do
 577           res <- mk_natural_ty 0 (ranged_word_bound ty) ty
 578           return $ Just $ (Arrow.second Right) res
 579         -- Create a custom type from this tycon
 580         otherwise -> mk_tycon_ty tycon args
 581     Nothing -> return $ Nothing
 582
 583 -- | Create VHDL type for a custom tycon
 584 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 585 mk_tycon_ty tycon args =
 586   case TyCon.tyConDataCons tycon of
 587     -- Not an algebraic type
 588     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
 589     [dc] -> do
 590       let arg_tys = DataCon.dataConRepArgTys dc
 591       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 592       -- violation? Or does it only mean not to apply it again to the same
 593       -- subject?
 594       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 595       elem_tys <- mapM vhdl_ty real_arg_tys
 596       let elems = zipWith AST.ElementDec recordlabels elem_tys
 597       -- For a single construct datatype, build a record with one field for
 598       -- each argument.
 599       -- TODO: Add argument type ids to this, to ensure uniqueness
 600       -- TODO: Special handling for tuples?
 601       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 602       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 603       return $ Just (ty_id, Left ty_def)
 604     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
 605   where
 606     -- Create a subst that instantiates all types passed to the tycon
 607     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 608     -- to work so far, though..
 609     tyvars = TyCon.tyConTyVars tycon
 610     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 611
 612 -- | Create a VHDL vector type
 613 mk_vector_ty ::
 614   Int -- ^ The length of the vector
 615   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 616   -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
 617
 618 mk_vector_ty len ty = do
 619   -- Assume there is a single type argument
 620   let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
 621   -- TODO: Use el_ty
 622   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 623   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 624   modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
 625   return (ty_id, ty_def)
 626
 627 mk_natural_ty ::
 628   Int -- ^ The minimum bound (> 0)
 629   -> Int -- ^ The maximum bound (> minimum bound)
 630   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 631   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 632 mk_natural_ty min_bound max_bound ty = do
 633   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 634   let ty_def = AST.SubtypeIn naturalTM (Nothing)
 635   return (ty_id, ty_def)
 636
 637
 638 builtin_types =
 639   Map.fromList [
 640     ("Bit", std_logic_ty),
 641     ("Bool", bool_ty) -- TysWiredIn.boolTy
 642   ]
 643
 644 -- Shortcut for
 645 -- Can only contain alphanumerics and underscores. The supplied string must be
 646 -- a valid basic id, otherwise an error value is returned. This function is
 647 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 648 -- that.
 649 mkVHDLBasicId :: String -> AST.VHDLId
 650 mkVHDLBasicId s =
 651   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 652   where
 653     -- Strip invalid characters.
 654     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 655     -- Strip leading numbers and underscores
 656     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 657     -- Strip multiple adjacent underscores
 658     strip_multiscore = concat . map (\cs ->
 659         case cs of
 660           ('_':_) -> "_"
 661           _ -> cs
 662       ) . List.group
 663
 664 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 665 -- different characters than basic ids, but can never be used to refer to
 666 -- basic ids.
 667 -- Use extended Ids for any values that are taken from the source file.
 668 mkVHDLExtId :: String -> AST.VHDLId
 669 mkVHDLExtId s =
 670   AST.unsafeVHDLExtId $ strip_invalid s
 671   where
 672     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 673     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 674     strip_invalid = filter (`elem` allowed)
 675
 676 -- Creates a VHDL Id from a binder
 677 bndrToVHDLId ::
 678   CoreSyn.CoreBndr
 679   -> AST.VHDLId
 680
 681 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 682
 683 -- Extracts the binder name as a String
 684 bndrToString ::
 685   CoreSyn.CoreBndr
 686   -> String
 687
 688 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 689
 690 -- Extracts the string version of the name
 691 nameToString :: Name.Name -> String
 692 nameToString = OccName.occNameString . Name.nameOccName
 693
 694 -- | A consise representation of a (set of) ports on a builtin function
 695 --type PortMap = HsValueMap (String, AST.TypeMark)
 696 -- | A consise representation of a builtin function
 697 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
 698
 699 -- | Translate a list of concise representation of builtin functions to a
 700 --   SignatureMap
 701 mkBuiltins :: [BuiltIn] -> SignatureMap
 702 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 703     (name,
 704      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
 705   )
 706
 707 builtin_hsfuncs = Map.keys builtin_funcs
 708 builtin_funcs = mkBuiltins
 709   [
 710     BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 711     BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 712     BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
 713     BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
 714   ]
 715
 716 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 717
 718 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 719 --   a VHDLSignalMap
 720 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 721 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)