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