clash/CLasH/VHDL/VHDLTools.hs

   1 {-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
   2 module CLasH.VHDL.VHDLTools where
   3
   4 -- Standard modules
   5 import qualified Maybe
   6 import qualified Data.Either as Either
   7 import qualified Data.List as List
   8 import qualified Data.Char as Char
   9 import qualified Data.Map as Map
  10 import qualified Control.Monad as Monad
  11 import qualified Data.Accessor.Monad.Trans.State as MonadState
  12
  13 -- VHDL Imports
  14 import qualified Language.VHDL.AST as AST
  15
  16 -- GHC API
  17 import qualified CoreSyn
  18 import qualified Name
  19 import qualified OccName
  20 import qualified Var
  21 import qualified Id
  22 import qualified TyCon
  23 import qualified Type
  24 import qualified DataCon
  25 import qualified CoreSubst
  26 import qualified Outputable
  27
  28 -- Local imports
  29 import CLasH.VHDL.VHDLTypes
  30 import CLasH.Translator.TranslatorTypes
  31 import CLasH.Utils.Core.CoreTools
  32 import CLasH.Utils
  33 import CLasH.Utils.Pretty
  34 import CLasH.VHDL.Constants
  35
  36 -----------------------------------------------------------------------------
  37 -- Functions to generate concurrent statements
  38 -----------------------------------------------------------------------------
  39
  40 -- Create an unconditional assignment statement
  41 mkUncondAssign ::
  42   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
  43   -> AST.Expr -- ^ The expression to assign
  44   -> AST.ConcSm -- ^ The resulting concurrent statement
  45 mkUncondAssign dst expr = mkAssign dst Nothing expr
  46
  47 -- Create a conditional assignment statement
  48 mkCondAssign ::
  49   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
  50   -> AST.Expr -- ^ The condition
  51   -> AST.Expr -- ^ The value when true
  52   -> AST.Expr -- ^ The value when false
  53   -> AST.ConcSm -- ^ The resulting concurrent statement
  54 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
  55
  56 -- Create a conditional or unconditional assignment statement
  57 mkAssign ::
  58   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
  59   -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
  60                                  -- and the value to assign when true.
  61   -> AST.Expr -- ^ The value to assign when false or no condition
  62   -> AST.ConcSm -- ^ The resulting concurrent statement
  63 mkAssign dst cond false_expr =
  64   let
  65     -- I'm not 100% how this assignment AST works, but this gets us what we
  66     -- want...
  67     whenelse = case cond of
  68       Just (cond_expr, true_expr) ->
  69         let
  70           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
  71         in
  72           [AST.WhenElse true_wform cond_expr]
  73       Nothing -> []
  74     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
  75     dst_name  = case dst of
  76       Left bndr -> AST.NSimple (varToVHDLId bndr)
  77       Right name -> name
  78     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
  79   in
  80     AST.CSSASm assign
  81
  82 mkAltsAssign ::
  83   Either CoreSyn.CoreBndr AST.VHDLName            -- ^ The signal to assign to
  84   -> [AST.Expr]       -- ^ The conditions
  85   -> [AST.Expr]       -- ^ The expressions
  86   -> AST.ConcSm   -- ^ The Alt assigns
  87 mkAltsAssign dst conds exprs
  88         | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
  89         | otherwise =
  90   let
  91     whenelses   = zipWith mkWhenElse conds exprs
  92     false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
  93     dst_name  = case dst of
  94       Left bndr -> AST.NSimple (varToVHDLId bndr)
  95       Right name -> name
  96     assign    = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
  97   in
  98     AST.CSSASm assign
  99   where
 100     mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
 101     mkWhenElse cond true_expr =
 102       let
 103         true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 104       in
 105         AST.WhenElse true_wform cond
 106
 107 mkAssocElems ::
 108   [AST.Expr]                    -- ^ The argument that are applied to function
 109   -> AST.VHDLName               -- ^ The binder in which to store the result
 110   -> Entity                     -- ^ The entity to map against.
 111   -> [AST.AssocElem]            -- ^ The resulting port maps
 112 mkAssocElems args res entity =
 113     arg_maps ++ (Maybe.maybeToList res_map_maybe)
 114   where
 115     arg_ports = ent_args entity
 116     res_port_maybe = ent_res entity
 117     -- Create an expression of res to map against the output port
 118     res_expr = vhdlNameToVHDLExpr res
 119     -- Map each of the input ports
 120     arg_maps = zipWith mkAssocElem (map fst arg_ports) args
 121     -- Map the output port, if present
 122     res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
 123
 124 -- | Create an VHDL port -> signal association
 125 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 126 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
 127
 128 -- | Create an aggregate signal
 129 mkAggregateSignal :: [AST.Expr] -> AST.Expr
 130 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
 131
 132 mkComponentInst ::
 133   String -- ^ The portmap label
 134   -> AST.VHDLId -- ^ The entity name
 135   -> [AST.AssocElem] -- ^ The port assignments
 136   -> AST.ConcSm
 137 mkComponentInst label entity_id portassigns = AST.CSISm compins
 138   where
 139     -- We always have a clock port, so no need to map it anywhere but here
 140     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
 141     resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
 142     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
 143
 144 -----------------------------------------------------------------------------
 145 -- Functions to generate VHDL Exprs
 146 -----------------------------------------------------------------------------
 147
 148 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 149 varToVHDLExpr var =
 150   case Id.isDataConWorkId_maybe var of
 151     -- This is a dataconstructor.
 152     Just dc -> dataconToVHDLExpr dc
 153     -- Not a datacon, just another signal.
 154     Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
 155
 156 -- Turn a VHDLName into an AST expression
 157 vhdlNameToVHDLExpr = AST.PrimName
 158
 159 -- Turn a VHDL Id into an AST expression
 160 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 161
 162 -- Turn a Core expression into an AST expression
 163 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 164
 165 -- Turn a String into a VHDL expr containing an id
 166 stringToVHDLExpr :: String -> AST.Expr
 167 stringToVHDLExpr = idToVHDLExpr . mkVHDLExtId
 168
 169
 170 -- Turn a alternative constructor into an AST expression. For
 171 -- dataconstructors, this is only the constructor itself, not any arguments it
 172 -- has. Should not be called with a DEFAULT constructor.
 173 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
 174 altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
 175
 176 altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 177 altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 178
 179 -- Turn a datacon (without arguments!) into a VHDL expression.
 180 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
 181 dataconToVHDLExpr dc = do
 182   typemap <- MonadState.get tsTypes
 183   htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
 184   case htype_either of
 185     -- No errors
 186     Right htype -> do
 187       let dcname = DataCon.dataConName dc
 188       case htype of
 189         (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 190         (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 191         otherwise -> do
 192           let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
 193           case existing_ty of
 194             Just ty -> do
 195               let lit    = AST.PrimLit $ show $ getConstructorIndex htype $ Name.getOccString dcname
 196               return lit
 197             Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
 198     -- Error when constructing htype
 199     Left err -> error err
 200
 201 -----------------------------------------------------------------------------
 202 -- Functions dealing with names, variables and ids
 203 -----------------------------------------------------------------------------
 204
 205 -- Creates a VHDL Id from a binder
 206 varToVHDLId ::
 207   CoreSyn.CoreBndr
 208   -> AST.VHDLId
 209 varToVHDLId var = mkVHDLExtId $ varToUniqString var
 210
 211 -- Creates a VHDL Name from a binder
 212 varToVHDLName ::
 213   CoreSyn.CoreBndr
 214   -> AST.VHDLName
 215 varToVHDLName = AST.NSimple . varToVHDLId
 216
 217 -- Extracts the binder name as a String
 218 varToString ::
 219   CoreSyn.CoreBndr
 220   -> String
 221 varToString = OccName.occNameString . Name.nameOccName . Var.varName
 222
 223 varToUniqString ::
 224   CoreSyn.CoreBndr
 225   -> String
 226 varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
 227   where
 228     lowers :: String -> Int
 229     lowers xs = length [x | x <- xs, Char.isLower x]
 230
 231 -- Get the string version a Var's unique
 232 varToStringUniq :: Var.Var -> String
 233 varToStringUniq = show . Var.varUnique
 234
 235 -- Extracts the string version of the name
 236 nameToString :: Name.Name -> String
 237 nameToString = OccName.occNameString . Name.nameOccName
 238
 239 -- Shortcut for Basic VHDL Ids.
 240 -- Can only contain alphanumerics and underscores. The supplied string must be
 241 -- a valid basic id, otherwise an error value is returned. This function is
 242 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 243 -- that.
 244 mkVHDLBasicId :: String -> AST.VHDLId
 245 mkVHDLBasicId s =
 246   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 247   where
 248     -- Strip invalid characters.
 249     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 250     -- Strip leading numbers and underscores
 251     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 252     -- Strip multiple adjacent underscores
 253     strip_multiscore = concatMap (\cs ->
 254         case cs of
 255           ('_':_) -> "_"
 256           _ -> cs
 257       ) . List.group
 258
 259 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 260 -- different characters than basic ids, but can never be used to refer to
 261 -- basic ids.
 262 -- Use extended Ids for any values that are taken from the source file.
 263 mkVHDLExtId :: String -> AST.VHDLId
 264 mkVHDLExtId s =
 265   (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
 266   where
 267     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 268     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
 269     strip_invalid = filter (`elem` allowed)
 270     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 271     strip_multiscore = concatMap (\cs ->
 272         case cs of
 273           ('_':_) -> "_"
 274           _ -> cs
 275       ) . List.group
 276
 277 -- Create a record field selector that selects the given label from the record
 278 -- stored in the given binder.
 279 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
 280 mkSelectedName name label =
 281    AST.NSelected $ name AST.:.: (AST.SSimple label)
 282
 283 -- Create an indexed name that selects a given element from a vector.
 284 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
 285 -- Special case for already indexed names. Just add an index
 286 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
 287  AST.NIndexed (AST.IndexedName name (indexes++[index]))
 288 -- General case for other names
 289 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 290
 291 -----------------------------------------------------------------------------
 292 -- Functions dealing with VHDL types
 293 -----------------------------------------------------------------------------
 294 builtin_types :: TypeMap
 295 builtin_types =
 296   Map.fromList [
 297     (BuiltinType "Bit", Just (std_logicTM, Nothing)),
 298     (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
 299   ]
 300
 301 -- Is the given type representable at runtime?
 302 isReprType :: Type.Type -> TypeSession Bool
 303 isReprType ty = do
 304   ty_either <- mkHTypeEither ty
 305   return $ case ty_either of
 306     Left _ -> False
 307     Right _ -> True
 308
 309 -- | Turn a Core type into a HType, returning an error using the given
 310 -- error string if the type was not representable.
 311 mkHType :: (TypedThing t, Outputable.Outputable t) =>
 312   String -> t -> TypeSession HType
 313 mkHType msg ty = do
 314   htype_either <- mkHTypeEither ty
 315   case htype_either of
 316     Right htype -> return htype
 317     Left err -> error $ msg ++ err
 318
 319 -- | Turn a Core type into a HType. Returns either an error message if
 320 -- the type was not representable, or the HType generated.
 321 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
 322   t -> TypeSession (Either String HType)
 323 mkHTypeEither tything =
 324   case getType tything of
 325     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
 326     Just ty -> mkHTypeEither' ty
 327
 328 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
 329 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
 330                   | isStateType ty = return $ Right StateType
 331                   | otherwise =
 332   case Type.splitTyConApp_maybe ty of
 333     Just (tycon, args) -> do
 334       typemap <- MonadState.get tsTypes
 335       let name = Name.getOccString (TyCon.tyConName tycon)
 336       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
 337       case builtinTyMaybe of
 338         (Just x) -> return $ Right $ BuiltinType name
 339         Nothing ->
 340           case name of
 341                 "Vector" -> do
 342                   let el_ty = tfvec_elem ty
 343                   elem_htype_either <- mkHTypeEither el_ty
 344                   case elem_htype_either of
 345                     -- Could create element type
 346                     Right elem_htype -> do
 347                       len <- tfp_to_int (tfvec_len_ty ty)
 348                       return $ Right $ VecType len elem_htype
 349                     -- Could not create element type
 350                     Left err -> return $ Left $
 351                       "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
 352                 "Unsigned" -> do
 353                   len <- tfp_to_int (sized_word_len_ty ty)
 354                   return $ Right $ SizedWType len
 355                 "Signed" -> do
 356                   len <- tfp_to_int (sized_word_len_ty ty)
 357                   return $ Right $ SizedIType len
 358                 "Index" -> do
 359                   bound <- tfp_to_int (ranged_word_bound_ty ty)
 360                   -- Upperbound is exclusive, hence the -1
 361                   return $ Right $ RangedWType (bound - 1)
 362                 otherwise ->
 363                   mkTyConHType tycon args
 364     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
 365
 366 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 367 mkTyConHType tycon args =
 368   case TyCon.tyConDataCons tycon of
 369     -- Not an algebraic type
 370     [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
 371     dcs -> do
 372       let arg_tyss = map DataCon.dataConRepArgTys dcs
 373       let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs)
 374       case (concat arg_tyss) of
 375         -- No arguments, this is just an enumeration type
 376         [] -> return (Right enum_ty)
 377         -- At least one argument, this becomes an aggregate type
 378         _ -> do
 379           -- Resolve any type arguments to this type
 380           let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss
 381           -- Remove any state type fields
 382           let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss
 383           elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate
 384           let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)
 385           case (all null errors) of
 386             True -> case (dcs, concat elem_htyss) of
 387                 -- A single constructor with a single (non-state) field?
 388                 ([dc], [elem_hty]) -> return $ Right elem_hty
 389                 -- If we get here, then all of the argument types were state
 390                 -- types (we check for enumeration types at the top). Not
 391                 -- sure how to handle this, so error out for now.
 392                 (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
 393                 -- A full ADT (with multiple fields and one or multiple
 394                 -- constructors).
 395                 (_, elem_htys) -> do
 396                   let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss
 397                   -- Only put in an enumeration as part of the aggregation
 398                   -- when there are multiple datacons
 399                   let enum_ty_part = case dcs of
 400                                       [dc] -> Nothing
 401                                       _ -> Just ("constructor", enum_ty)
 402                   -- Create the AggrType HType
 403                   return $ Right $ AggrType name enum_ty_part fieldss
 404                 -- There were errors in element types
 405             False -> return $ Left $
 406               "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 407               ++ (concat $ concat errors)
 408   where
 409     name = (nameToString (TyCon.tyConName tycon))
 410     tyvars = TyCon.tyConTyVars tycon
 411     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 412     -- Label a field by taking the first available label and returning
 413     -- the rest.
 414     label_field :: [String] -> HType -> ([String], (String, HType))
 415     label_field (l:ls) htype = (ls, (l, htype))
 416     labels = map (:[]) ['A'..'Z']
 417
 418 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
 419   String -> t -> TypeSession (Maybe AST.TypeMark)
 420 vhdlTy msg ty = do
 421   htype <- mkHType msg ty
 422   vhdlTyMaybe htype
 423
 424 -- | Translate a Haskell type to a VHDL type, generating a new type if needed.
 425 -- Returns an error value, using the given message, when no type could be
 426 -- created. Returns Nothing when the type is valid, but empty.
 427 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
 428 vhdlTyMaybe htype = do
 429   typemap <- MonadState.get tsTypes
 430   -- If not a builtin type, try the custom types
 431   let existing_ty = Map.lookup htype typemap
 432   case existing_ty of
 433     -- Found a type, return it
 434     Just (Just (t, _)) -> return $ Just t
 435     Just (Nothing) -> return Nothing
 436     -- No type yet, try to construct it
 437     Nothing -> do
 438       newty <- (construct_vhdl_ty htype)
 439       MonadState.modify tsTypes (Map.insert htype newty)
 440       case newty of
 441         Just (ty_id, ty_def) -> do
 442           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
 443           return $ Just ty_id
 444         Nothing -> return Nothing
 445
 446 -- Construct a new VHDL type for the given Haskell type. Returns an error
 447 -- message or the resulting typemark and typedef.
 448 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
 449 -- State types don't generate VHDL
 450 construct_vhdl_ty htype =
 451     case htype of
 452       StateType -> return  Nothing
 453       (SizedWType w) -> mkUnsignedTy w
 454       (SizedIType i) -> mkSignedTy i
 455       (RangedWType u) -> mkNaturalTy 0 u
 456       (VecType n e) -> mkVectorTy (VecType n e)
 457       -- Create a custom type from this tycon
 458       otherwise -> mkTyconTy htype
 459
 460 -- | Create VHDL type for a custom tycon
 461 mkTyconTy :: HType -> TypeSession TypeMapRec
 462 mkTyconTy htype =
 463   case htype of
 464     (AggrType name enum_field_maybe fieldss) -> do
 465       let (labelss, elem_htypess) = unzip (map unzip fieldss)
 466       elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess
 467       let elem_tyss = map Maybe.catMaybes elemTyMaybess
 468       case concat elem_tyss of
 469         [] -> -- No non-empty fields
 470           return Nothing
 471         _ -> do
 472           let reclabelss = map (map mkVHDLBasicId) labelss
 473           let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss
 474           let elem_names = concatMap (concatMap prettyShow) elem_tyss
 475           let ty_id = mkVHDLExtId $ name ++ elem_names
 476           -- Find out if we need to add an extra field at the start of
 477           -- the record type containing the constructor (only needed
 478           -- when there's more than one constructor).
 479           enum_ty_maybe <- case enum_field_maybe of
 480             Nothing -> return Nothing
 481             Just (_, enum_htype) -> do
 482               enum_ty_maybe' <- vhdlTyMaybe enum_htype
 483               case enum_ty_maybe' of
 484                 Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype
 485                 -- Note that the first Just means the type is
 486                 -- translateable, while the second Just means that there
 487                 -- is a enum_ty at all (e.g., there's multiple
 488                 -- constructors).
 489                 Just enum_ty -> return $ Just enum_ty
 490           -- Create an record field declaration for the first
 491           -- constructor field, if needed.
 492           enum_dec_maybe <- case enum_field_maybe of
 493             Nothing -> return $ Nothing
 494             Just (enum_name, enum_htype) -> do
 495               enum_vhdl_ty_maybe <- vhdlTyMaybe  enum_htype
 496               let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe
 497               return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty
 498           -- Turn the maybe into a list, so we can prepend it.
 499           let enum_decs = Maybe.maybeToList enum_dec_maybe
 500           let enum_tys = Maybe.maybeToList enum_ty_maybe
 501           let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
 502           let aggrshow = case enum_field_maybe of
 503                           Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
 504                           Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
 505           MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
 506           return $ Just (ty_id, Just $ Left ty_def)
 507     (EnumType tycon dcs) -> do
 508       let ty_id = mkVHDLExtId tycon
 509       let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
 510       let ty_def = AST.TDI $ AST.IntegerTypeDef range
 511       let enumShow = mkEnumShow dcs ty_id
 512       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
 513       return $ Just (ty_id, Just $ Left ty_def)
 514     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
 515
 516 -- | Create a VHDL vector type
 517 mkVectorTy ::
 518   HType -- ^ The Haskell type of the Vector
 519   -> TypeSession TypeMapRec
 520       -- ^ An error message or The typemark created.
 521
 522 mkVectorTy (VecType len elHType) = do
 523   typesMap <- MonadState.get tsTypes
 524   elTyTmMaybe <- vhdlTyMaybe elHType
 525   case elTyTmMaybe of
 526     (Just elTyTm) -> do
 527       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
 528       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 529       let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
 530       case existing_uvec_ty of
 531         Just (Just t) -> do
 532           let ty_def = AST.SubtypeIn t (Just range)
 533           return (Just (ty_id, Just $ Right ty_def))
 534         Nothing -> do
 535           let vec_id  = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
 536           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
 537           MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
 538           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
 539           let vecShowFuns = mkVectorShow elTyTm vec_id
 540           mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
 541           let ty_def = AST.SubtypeIn vec_id (Just range)
 542           return (Just (ty_id, Just $ Right ty_def))
 543     -- Vector of empty elements becomes empty itself.
 544     Nothing -> return Nothing
 545 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
 546
 547 mkNaturalTy ::
 548   Int -- ^ The minimum bound (> 0)
 549   -> Int -- ^ The maximum bound (> minimum bound)
 550   -> TypeSession TypeMapRec
 551       -- ^ An error message or The typemark created.
 552 mkNaturalTy min_bound max_bound = do
 553   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
 554   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 555   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
 556   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 557   return (Just (ty_id, Just $ Right ty_def))
 558
 559 mkUnsignedTy ::
 560   Int -- ^ Haskell type of the unsigned integer
 561   -> TypeSession TypeMapRec
 562 mkUnsignedTy size = do
 563   let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
 564   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
 565   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 566   return (Just (ty_id, Just $ Right ty_def))
 567
 568 mkSignedTy ::
 569   Int -- ^ Haskell type of the signed integer
 570   -> TypeSession TypeMapRec
 571 mkSignedTy size = do
 572   let ty_id = mkVHDLExtId $ "signed_" ++ show size
 573   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
 574   let ty_def = AST.SubtypeIn signedTM (Just range)
 575   return (Just (ty_id, Just $ Right ty_def))
 576
 577 -- Finds the field labels and types for aggregation HType. Returns an
 578 -- error on other types.
 579 getFields ::
 580   HType                -- ^ The HType to get fields for
 581   -> Int               -- ^ The constructor to get fields for (e.g., 0
 582                        --   for the first constructor, etc.)
 583   -> [(String, HType)] -- ^ A list of fields, with their name and type
 584 getFields htype dc_i = case htype of
 585   (AggrType name _ fieldss)
 586     | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i
 587     | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
 588   _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype
 589
 590 -- Finds the field labels for an aggregation type, as VHDLIds.
 591 getFieldLabels ::
 592   HType                -- ^ The HType to get field labels for
 593   -> Int               -- ^ The constructor to get fields for (e.g., 0
 594                        --   for the first constructor, etc.)
 595   -> [AST.VHDLId]      -- ^ The labels
 596 getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)
 597
 598 -- Finds the field label for the constructor field, if any.
 599 getConstructorFieldLabel ::
 600   HType
 601   -> Maybe AST.VHDLId
 602 getConstructorFieldLabel (AggrType _ (Just con) _) =
 603         Just $ mkVHDLBasicId (fst con)
 604 getConstructorFieldLabel (AggrType _ Nothing _) =
 605         Nothing
 606 getConstructorFieldLabel htype =
 607         error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
 608
 609
 610 getConstructorIndex ::
 611   HType ->
 612   String ->
 613   Int
 614 getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
 615   Just (index) -> index
 616   Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
 617 getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype
 618
 619
 620 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
 621 mytydecl (_, Nothing) = Nothing
 622 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
 623 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
 624
 625 mkTupleShow ::
 626   [AST.TypeMark] -- ^ type of each tuple element
 627   -> AST.TypeMark -- ^ type of the tuple
 628   -> AST.SubProgBody
 629 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
 630   where
 631     tupPar    = AST.unsafeVHDLBasicId "tup"
 632     parenPar  = AST.unsafeVHDLBasicId "paren"
 633     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 634     showExpr  = AST.ReturnSm (Just $
 635                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
 636       where
 637         showMiddle = if null elemTMs then
 638             AST.PrimLit "''"
 639           else
 640             foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
 641               map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false")))
 642                   (take tupSize recordlabels)
 643     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 644     tupSize = length elemTMs
 645     selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
 646
 647 mkAdtShow ::
 648   String
 649   -> [String] -- Constructors
 650   -> [[String]] -- Fields for every constructor
 651   -> AST.TypeMark
 652   -> AST.SubProgBody
 653 mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
 654   where
 655     adtPar   = AST.unsafeVHDLBasicId "adt"
 656     parenPar = AST.unsafeVHDLBasicId "paren"
 657     showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 658     showExpr  = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
 659                   [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (
 660                     if (null (elemIdss!!x)) then
 661                         [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
 662                       else
 663                         [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
 664                     ) | x <- [0..(length conIds) -1]]
 665     showFields i = if (null (elemIdss!!i)) then
 666         AST.PrimLit "\"\""
 667       else
 668         foldr1 (\e1 e2 -> e1 AST.:&: e2) $
 669               map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))
 670                   (map mkVHDLBasicId (elemIdss!!i))
 671     selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
 672     addParens :: AST.Expr -> AST.SeqSm
 673     addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))
 674                     [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]
 675                     []
 676                     (Just $ AST.Else [AST.ReturnSm (Just k)])
 677
 678 mkEnumShow ::
 679   [String]
 680   -> AST.TypeMark
 681   -> AST.SubProgBody
 682 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
 683   where
 684     enumPar   = AST.unsafeVHDLBasicId "enum"
 685     parenPar  = AST.unsafeVHDLBasicId "paren"
 686     showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 687     showExpr  = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
 688                   [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
 689
 690
 691 mkVectorShow ::
 692   AST.TypeMark -- ^ elemtype
 693   -> AST.TypeMark -- ^ vectype
 694   -> [(String,AST.SubProgBody)]
 695 mkVectorShow elemTM vectorTM =
 696   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
 697   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
 698   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
 699   ]
 700   where
 701     vecPar  = AST.unsafeVHDLBasicId "vec"
 702     resId   = AST.unsafeVHDLBasicId "res"
 703     parenPar = AST.unsafeVHDLBasicId "paren"
 704     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 705     -- return vec(0);
 706     headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
 707                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
 708     vecSlice init last =  AST.PrimName (AST.NSlice
 709                                       (AST.SliceName
 710                                             (AST.NSimple vecPar)
 711                                             (AST.ToRange init last)))
 712     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 713        -- variable res : fsvec_x (0 to vec'length-2);
 714     tailVar =
 715          AST.VarDec resId
 716                 (AST.SubtypeIn vectorTM
 717                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 718                    [AST.ToRange (AST.PrimLit "0")
 719                             (AST.PrimName (AST.NAttribute $
 720                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 721                                 (AST.PrimLit "2"))   ]))
 722                 Nothing
 723        -- res AST.:= vec(1 to vec'length-1)
 724     tailExpr = AST.NSimple resId AST.:= (vecSlice
 725                                (AST.PrimLit "1")
 726                                (AST.PrimName (AST.NAttribute $
 727                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 728                                                              AST.:-: AST.PrimLit "1"))
 729     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 730     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 731     doShowId  = AST.unsafeVHDLBasicId "doshow"
 732     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
 733       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
 734                                            stringTM
 735             -- case vec'len is
 736             --  when  0 => return "";
 737             --  when  1 => return head(vec);
 738             --  when others => return show(head(vec)) & ',' &
 739             --                        doshow (tail(vec));
 740             -- end case;
 741             doShowRet =
 742               AST.CaseSm (AST.PrimName (AST.NAttribute $
 743                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 744               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
 745                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
 746                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
 747                          [AST.ReturnSm (Just $
 748                           genExprFCall2 showId
 749                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )],
 750                AST.CaseSmAlt [AST.Others]
 751                          [AST.ReturnSm (Just $
 752                            genExprFCall2 showId
 753                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&:
 754                            AST.PrimLit "','" AST.:&:
 755                            genExprFCall doShowId
 756                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
 757     -- return '<' & doshow(vec) & '>';
 758     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
 759                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
 760                                AST.PrimLit "'>'" )
 761
 762 mkBuiltInShow :: [AST.SubProgBody]
 763 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
 764                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
 765                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
 766                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
 767                 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
 768                 ]
 769   where
 770     bitPar      = AST.unsafeVHDLBasicId "s"
 771     boolPar     = AST.unsafeVHDLBasicId "b"
 772     signedPar   = AST.unsafeVHDLBasicId "sint"
 773     unsignedPar = AST.unsafeVHDLBasicId "uint"
 774     parenPar    = AST.unsafeVHDLBasicId "paren"
 775     -- naturalPar  = AST.unsafeVHDLBasicId "nat"
 776     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 777     -- if s = '1' then return "'1'" else return "'0'"
 778     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
 779                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
 780                         []
 781                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
 782     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 783     -- if b then return "True" else return "False"
 784     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
 785                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
 786                         []
 787                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
 788     showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 789     showSignedExpr =  AST.ReturnSm (Just $
 790                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 791                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
 792                       where
 793                         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
 794     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
 795     showUnsignedExpr =  AST.ReturnSm (Just $
 796                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 797                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
 798                         where
 799                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
 800     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
 801     -- showNaturalExpr = AST.ReturnSm (Just $
 802     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 803     --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
 804
 805
 806 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 807 genExprFCall fName args =
 808    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
 809              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
 810
 811 genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr
 812 genExprFCall2 fName (arg1, arg2) =
 813    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
 814              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 815
 816 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
 817 genExprPCall2 entid arg1 arg2 =
 818         AST.ProcCall (AST.NSimple entid) $
 819          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 820
 821 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
 822 mkSigDec bndr = do
 823   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 824   type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
 825   case type_mark_maybe of
 826     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 827     Nothing -> return Nothing
 828
 829 -- | Does the given thing have a non-empty type?
 830 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
 831   t -> TranslatorSession Bool
 832 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)