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    = idToVHDLExpr $ mkVHDLExtId $ 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 (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
 210   where
 211     lowers :: String -> Int
 212     lowers xs = length [x | x <- xs, Char.isLower x]
 213
 214 -- Creates a VHDL Name from a binder
 215 varToVHDLName ::
 216   CoreSyn.CoreBndr
 217   -> AST.VHDLName
 218 varToVHDLName = AST.NSimple . varToVHDLId
 219
 220 -- Extracts the binder name as a String
 221 varToString ::
 222   CoreSyn.CoreBndr
 223   -> String
 224 varToString = OccName.occNameString . Name.nameOccName . Var.varName
 225
 226 -- Get the string version a Var's unique
 227 varToStringUniq :: Var.Var -> String
 228 varToStringUniq = show . Var.varUnique
 229
 230 -- Extracts the string version of the name
 231 nameToString :: Name.Name -> String
 232 nameToString = OccName.occNameString . Name.nameOccName
 233
 234 -- Shortcut for Basic VHDL Ids.
 235 -- Can only contain alphanumerics and underscores. The supplied string must be
 236 -- a valid basic id, otherwise an error value is returned. This function is
 237 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 238 -- that.
 239 mkVHDLBasicId :: String -> AST.VHDLId
 240 mkVHDLBasicId s =
 241   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 242   where
 243     -- Strip invalid characters.
 244     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 245     -- Strip leading numbers and underscores
 246     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 247     -- Strip multiple adjacent underscores
 248     strip_multiscore = concatMap (\cs ->
 249         case cs of
 250           ('_':_) -> "_"
 251           _ -> cs
 252       ) . List.group
 253
 254 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 255 -- different characters than basic ids, but can never be used to refer to
 256 -- basic ids.
 257 -- Use extended Ids for any values that are taken from the source file.
 258 mkVHDLExtId :: String -> AST.VHDLId
 259 mkVHDLExtId s =
 260   AST.unsafeVHDLExtId $ strip_invalid s
 261   where
 262     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 263     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
 264     strip_invalid = filter (`elem` allowed)
 265
 266 -- Create a record field selector that selects the given label from the record
 267 -- stored in the given binder.
 268 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
 269 mkSelectedName name label =
 270    AST.NSelected $ name AST.:.: (AST.SSimple label)
 271
 272 -- Create an indexed name that selects a given element from a vector.
 273 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
 274 -- Special case for already indexed names. Just add an index
 275 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
 276  AST.NIndexed (AST.IndexedName name (indexes++[index]))
 277 -- General case for other names
 278 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 279
 280 -----------------------------------------------------------------------------
 281 -- Functions dealing with VHDL types
 282 -----------------------------------------------------------------------------
 283 builtin_types :: TypeMap
 284 builtin_types =
 285   Map.fromList [
 286     (BuiltinType "Bit", Just (std_logicTM, Nothing)),
 287     (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
 288   ]
 289
 290 -- Is the given type representable at runtime?
 291 isReprType :: Type.Type -> TypeSession Bool
 292 isReprType ty = do
 293   ty_either <- mkHTypeEither ty
 294   return $ case ty_either of
 295     Left _ -> False
 296     Right _ -> True
 297
 298 -- | Turn a Core type into a HType, returning an error using the given
 299 -- error string if the type was not representable.
 300 mkHType :: (TypedThing t, Outputable.Outputable t) =>
 301   String -> t -> TypeSession HType
 302 mkHType msg ty = do
 303   htype_either <- mkHTypeEither ty
 304   case htype_either of
 305     Right htype -> return htype
 306     Left err -> error $ msg ++ err
 307
 308 -- | Turn a Core type into a HType. Returns either an error message if
 309 -- the type was not representable, or the HType generated.
 310 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
 311   t -> TypeSession (Either String HType)
 312 mkHTypeEither tything =
 313   case getType tything of
 314     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
 315     Just ty -> mkHTypeEither' ty
 316
 317 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
 318 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
 319                   | isStateType ty = return $ Right StateType
 320                   | otherwise =
 321   case Type.splitTyConApp_maybe ty of
 322     Just (tycon, args) -> do
 323       typemap <- MonadState.get tsTypes
 324       let name = Name.getOccString (TyCon.tyConName tycon)
 325       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
 326       case builtinTyMaybe of
 327         (Just x) -> return $ Right $ BuiltinType name
 328         Nothing ->
 329           case name of
 330                 "Vector" -> do
 331                   let el_ty = tfvec_elem ty
 332                   elem_htype_either <- mkHTypeEither el_ty
 333                   case elem_htype_either of
 334                     -- Could create element type
 335                     Right elem_htype -> do
 336                       len <- tfp_to_int (tfvec_len_ty ty)
 337                       return $ Right $ VecType len elem_htype
 338                     -- Could not create element type
 339                     Left err -> return $ Left $
 340                       "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
 341                 "Unsigned" -> do
 342                   len <- tfp_to_int (sized_word_len_ty ty)
 343                   return $ Right $ SizedWType len
 344                 "Signed" -> do
 345                   len <- tfp_to_int (sized_word_len_ty ty)
 346                   return $ Right $ SizedIType len
 347                 "Index" -> do
 348                   bound <- tfp_to_int (ranged_word_bound_ty ty)
 349                   return $ Right $ RangedWType bound
 350                 otherwise ->
 351                   mkTyConHType tycon args
 352     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
 353
 354 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 355 mkTyConHType tycon args =
 356   case TyCon.tyConDataCons tycon of
 357     -- Not an algebraic type
 358     [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
 359     [dc] -> do
 360       let arg_tys = DataCon.dataConRepArgTys dc
 361       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 362       let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
 363       elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
 364       case Either.partitionEithers elem_htys_either of
 365         ([], [elem_hty]) ->
 366           return $ Right elem_hty
 367         -- No errors in element types
 368         ([], elem_htys) ->
 369           return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
 370         -- There were errors in element types
 371         (errors, _) -> return $ Left $
 372           "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 373           ++ (concat errors)
 374     dcs -> do
 375       let arg_tys = concatMap DataCon.dataConRepArgTys dcs
 376       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 377       case real_arg_tys of
 378         [] ->
 379           return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
 380         xs -> return $ Left $
 381           "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
 382   where
 383     tyvars = TyCon.tyConTyVars tycon
 384     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 385
 386 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 387 -- Returns an error value, using the given message, when no type could be
 388 -- created. Returns Nothing when the type is valid, but empty.
 389 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
 390   String -> t -> TypeSession (Maybe AST.TypeMark)
 391 vhdlTy msg ty = do
 392   htype <- mkHType msg ty
 393   vhdlTyMaybe htype
 394
 395 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
 396 vhdlTyMaybe htype = do
 397   typemap <- MonadState.get tsTypes
 398   -- If not a builtin type, try the custom types
 399   let existing_ty = Map.lookup htype typemap
 400   case existing_ty of
 401     -- Found a type, return it
 402     Just (Just (t, _)) -> return $ Just t
 403     Just (Nothing) -> return Nothing
 404     -- No type yet, try to construct it
 405     Nothing -> do
 406       newty <- (construct_vhdl_ty htype)
 407       MonadState.modify tsTypes (Map.insert htype newty)
 408       case newty of
 409         Just (ty_id, ty_def) -> do
 410           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
 411           return $ Just ty_id
 412         Nothing -> return Nothing
 413
 414 -- Construct a new VHDL type for the given Haskell type. Returns an error
 415 -- message or the resulting typemark and typedef.
 416 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
 417 -- State types don't generate VHDL
 418 construct_vhdl_ty htype =
 419     case htype of
 420       StateType -> return  Nothing
 421       (SizedWType w) -> mkUnsignedTy w
 422       (SizedIType i) -> mkSignedTy i
 423       (RangedWType u) -> mkNaturalTy 0 u
 424       (VecType n e) -> mkVectorTy (VecType n e)
 425       -- Create a custom type from this tycon
 426       otherwise -> mkTyconTy htype
 427
 428 -- | Create VHDL type for a custom tycon
 429 mkTyconTy :: HType -> TypeSession TypeMapRec
 430 mkTyconTy htype =
 431   case htype of
 432     (AggrType tycon args) -> do
 433       elemTysMaybe <- mapM vhdlTyMaybe args
 434       case Maybe.catMaybes elemTysMaybe of
 435         [] -> -- No non-empty members
 436           return Nothing
 437         elem_tys -> do
 438           let elems = zipWith AST.ElementDec recordlabels elem_tys
 439           let elem_names = concatMap prettyShow elem_tys
 440           let ty_id = mkVHDLExtId $ tycon ++ elem_names
 441           let ty_def = AST.TDR $ AST.RecordTypeDef elems
 442           let tupshow = mkTupleShow elem_tys ty_id
 443           MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
 444           return $ Just (ty_id, Just $ Left ty_def)
 445     (EnumType tycon dcs) -> do
 446       let elems = map mkVHDLExtId dcs
 447       let ty_id = mkVHDLExtId tycon
 448       let ty_def = AST.TDE $ AST.EnumTypeDef elems
 449       let enumShow = mkEnumShow elems ty_id
 450       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
 451       return $ Just (ty_id, Just $ Left ty_def)
 452     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
 453   where
 454     -- Generate a bunch of labels for fields of a record
 455     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 456
 457 -- | Create a VHDL vector type
 458 mkVectorTy ::
 459   HType -- ^ The Haskell type of the Vector
 460   -> TypeSession TypeMapRec
 461       -- ^ An error message or The typemark created.
 462
 463 mkVectorTy (VecType len elHType) = do
 464   typesMap <- MonadState.get tsTypes
 465   elTyTmMaybe <- vhdlTyMaybe elHType
 466   case elTyTmMaybe of
 467     (Just elTyTm) -> do
 468       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
 469       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 470       let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
 471       case existing_uvec_ty of
 472         Just (Just t) -> do
 473           let ty_def = AST.SubtypeIn t (Just range)
 474           return (Just (ty_id, Just $ Right ty_def))
 475         Nothing -> do
 476           let vec_id  = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
 477           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
 478           MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
 479           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
 480           let vecShowFuns = mkVectorShow elTyTm vec_id
 481           mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
 482           let ty_def = AST.SubtypeIn vec_id (Just range)
 483           return (Just (ty_id, Just $ Right ty_def))
 484     -- Vector of empty elements becomes empty itself.
 485     Nothing -> return Nothing
 486 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
 487
 488 mkNaturalTy ::
 489   Int -- ^ The minimum bound (> 0)
 490   -> Int -- ^ The maximum bound (> minimum bound)
 491   -> TypeSession TypeMapRec
 492       -- ^ An error message or The typemark created.
 493 mkNaturalTy min_bound max_bound = do
 494   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
 495   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 496   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
 497   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 498   return (Just (ty_id, Just $ Right ty_def))
 499
 500 mkUnsignedTy ::
 501   Int -- ^ Haskell type of the unsigned integer
 502   -> TypeSession TypeMapRec
 503 mkUnsignedTy size = do
 504   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
 505   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 506   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 507   return (Just (ty_id, Just $ Right ty_def))
 508
 509 mkSignedTy ::
 510   Int -- ^ Haskell type of the signed integer
 511   -> TypeSession TypeMapRec
 512 mkSignedTy size = do
 513   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
 514   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 515   let ty_def = AST.SubtypeIn signedTM (Just range)
 516   return (Just (ty_id, Just $ Right ty_def))
 517
 518 -- Finds the field labels for VHDL type generated for the given Core type,
 519 -- which must result in a record type.
 520 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
 521 getFieldLabels ty = do
 522   -- Ensure that the type is generated (but throw away it's VHDLId)
 523   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
 524   vhdlTy error_msg ty
 525   -- Get the types map, lookup and unpack the VHDL TypeDef
 526   types <- MonadState.get tsTypes
 527   -- Assume the type for which we want labels is really translatable
 528   htype <- mkHType error_msg ty
 529   case Map.lookup htype types of
 530     Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype)
 531     Just Nothing -> return [] -- The type is empty
 532     Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 533     Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
 534
 535 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
 536 mytydecl (_, Nothing) = Nothing
 537 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
 538 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
 539
 540 mkTupleShow ::
 541   [AST.TypeMark] -- ^ type of each tuple element
 542   -> AST.TypeMark -- ^ type of the tuple
 543   -> AST.SubProgBody
 544 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
 545   where
 546     tupPar    = AST.unsafeVHDLBasicId "tup"
 547     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
 548     showExpr  = AST.ReturnSm (Just $
 549                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
 550       where
 551         showMiddle = if null elemTMs then
 552             AST.PrimLit "''"
 553           else
 554             foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
 555               map ((genExprFCall showId).
 556                     AST.PrimName .
 557                     AST.NSelected .
 558                     (AST.NSimple tupPar AST.:.:).
 559                     tupVHDLSuffix)
 560                   (take tupSize recordlabels)
 561     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 562     tupSize = length elemTMs
 563
 564 mkEnumShow ::
 565   [AST.VHDLId]
 566   -> AST.TypeMark
 567   -> AST.SubProgBody
 568 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
 569   where
 570     enumPar    = AST.unsafeVHDLBasicId "enum"
 571     showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
 572     showExpr  = AST.ReturnSm (Just $
 573                   AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
 574
 575 mkVectorShow ::
 576   AST.TypeMark -- ^ elemtype
 577   -> AST.TypeMark -- ^ vectype
 578   -> [(String,AST.SubProgBody)]
 579 mkVectorShow elemTM vectorTM =
 580   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
 581   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
 582   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
 583   ]
 584   where
 585     vecPar  = AST.unsafeVHDLBasicId "vec"
 586     resId   = AST.unsafeVHDLBasicId "res"
 587     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 588     -- return vec(0);
 589     headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
 590                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
 591     vecSlice init last =  AST.PrimName (AST.NSlice
 592                                       (AST.SliceName
 593                                             (AST.NSimple vecPar)
 594                                             (AST.ToRange init last)))
 595     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 596        -- variable res : fsvec_x (0 to vec'length-2);
 597     tailVar =
 598          AST.VarDec resId
 599                 (AST.SubtypeIn vectorTM
 600                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 601                    [AST.ToRange (AST.PrimLit "0")
 602                             (AST.PrimName (AST.NAttribute $
 603                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 604                                 (AST.PrimLit "2"))   ]))
 605                 Nothing
 606        -- res AST.:= vec(1 to vec'length-1)
 607     tailExpr = AST.NSimple resId AST.:= (vecSlice
 608                                (AST.PrimLit "1")
 609                                (AST.PrimName (AST.NAttribute $
 610                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 611                                                              AST.:-: AST.PrimLit "1"))
 612     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 613     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
 614     doShowId  = AST.unsafeVHDLExtId "doshow"
 615     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
 616       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
 617                                            stringTM
 618             -- case vec'len is
 619             --  when  0 => return "";
 620             --  when  1 => return head(vec);
 621             --  when others => return show(head(vec)) & ',' &
 622             --                        doshow (tail(vec));
 623             -- end case;
 624             doShowRet =
 625               AST.CaseSm (AST.PrimName (AST.NAttribute $
 626                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 627               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
 628                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
 629                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
 630                          [AST.ReturnSm (Just $
 631                           genExprFCall showId
 632                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
 633                AST.CaseSmAlt [AST.Others]
 634                          [AST.ReturnSm (Just $
 635                            genExprFCall showId
 636                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
 637                            AST.PrimLit "','" AST.:&:
 638                            genExprFCall doShowId
 639                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
 640     -- return '<' & doshow(vec) & '>';
 641     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
 642                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
 643                                AST.PrimLit "'>'" )
 644
 645 mkBuiltInShow :: [AST.SubProgBody]
 646 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
 647                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
 648                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
 649                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
 650                 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
 651                 ]
 652   where
 653     bitPar      = AST.unsafeVHDLBasicId "s"
 654     boolPar     = AST.unsafeVHDLBasicId "b"
 655     signedPar   = AST.unsafeVHDLBasicId "sint"
 656     unsignedPar = AST.unsafeVHDLBasicId "uint"
 657     -- naturalPar  = AST.unsafeVHDLBasicId "nat"
 658     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
 659     -- if s = '1' then return "'1'" else return "'0'"
 660     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
 661                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
 662                         []
 663                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
 664     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
 665     -- if b then return "True" else return "False"
 666     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
 667                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
 668                         []
 669                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
 670     showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
 671     showSignedExpr =  AST.ReturnSm (Just $
 672                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 673                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
 674                       where
 675                         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
 676     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
 677     showUnsignedExpr =  AST.ReturnSm (Just $
 678                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 679                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
 680                         where
 681                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
 682     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
 683     -- showNaturalExpr = AST.ReturnSm (Just $
 684     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 685     --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
 686
 687
 688 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 689 genExprFCall fName args =
 690    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
 691              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
 692
 693 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
 694 genExprPCall2 entid arg1 arg2 =
 695         AST.ProcCall (AST.NSimple entid) $
 696          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 697
 698 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
 699 mkSigDec bndr = do
 700   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 701   type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
 702   case type_mark_maybe of
 703     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 704     Nothing -> return Nothing
 705
 706 -- | Does the given thing have a non-empty type?
 707 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
 708   t -> TranslatorSession Bool
 709 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)