X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=785b528afb1140db80655c62a7346b6a3bdc2f88;hb=cf39807bf7b8424b6db0bc07a922a19972786735;hp=412e0c4a2dfa26193b33777f19282b169c3be8c0;hpb=46f158b38c85034e5bef234df4436ea279f895f9;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 412e0c4..785b528 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -1,9 +1,11 @@ +{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason... module CLasH.VHDL.VHDLTools where -- Standard modules import qualified Maybe import qualified Data.Either as Either import qualified Data.List as List +import qualified Data.Char as Char import qualified Data.Map as Map import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow @@ -27,10 +29,13 @@ import qualified TyCon import qualified Type import qualified DataCon import qualified CoreSubst +import qualified Outputable -- Local imports import CLasH.VHDL.VHDLTypes +import CLasH.Translator.TranslatorTypes import CLasH.Utils.Core.CoreTools +import CLasH.Utils import CLasH.Utils.Pretty import CLasH.VHDL.Constants @@ -68,7 +73,7 @@ mkAssign dst cond false_expr = whenelse = case cond of Just (cond_expr, true_expr) -> let - true_wform = AST.Wform [AST.WformElem true_expr Nothing] + true_wform = AST.Wform [AST.WformElem true_expr Nothing] in [AST.WhenElse true_wform cond_expr] Nothing -> [] @@ -80,33 +85,55 @@ mkAssign dst cond false_expr = in AST.CSSASm assign +mkAltsAssign :: + Either CoreBndr AST.VHDLName -- ^ The signal to assign to + -> [AST.Expr] -- ^ The conditions + -> [AST.Expr] -- ^ The expressions + -> AST.ConcSm -- ^ The Alt assigns +mkAltsAssign dst conds exprs + | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch" + | otherwise = + let + whenelses = zipWith mkWhenElse conds exprs + false_wform = AST.Wform [AST.WformElem (last exprs) Nothing] + dst_name = case dst of + Left bndr -> AST.NSimple (varToVHDLId bndr) + Right name -> name + assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing) + in + AST.CSSASm assign + where + mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse + mkWhenElse cond true_expr = + let + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + in + AST.WhenElse true_wform cond + mkAssocElems :: [AST.Expr] -- ^ The argument that are applied to function -> AST.VHDLName -- ^ The binder in which to store the result -> Entity -- ^ The entity to map against. -> [AST.AssocElem] -- ^ The resulting port maps mkAssocElems args res entity = - -- Create the actual AssocElems - zipWith mkAssocElem ports sigs + arg_maps ++ (Maybe.maybeToList res_map_maybe) where - -- Turn the ports and signals from a map into a flat list. This works, - -- since the maps must have an identical form by definition. TODO: Check - -- the similar form? arg_ports = ent_args entity - res_port = ent_res entity - -- Extract the id part from the (id, type) tuple - ports = map fst (res_port : arg_ports) - -- Translate signal numbers into names - sigs = (vhdlNameToVHDLExpr res : args) + res_port_maybe = ent_res entity + -- Create an expression of res to map against the output port + res_expr = vhdlNameToVHDLExpr res + -- Map each of the input ports + arg_maps = zipWith mkAssocElem (map fst arg_ports) args + -- Map the output port, if present + res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe -- | Create an VHDL port -> signal association mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) --- | Create an VHDL port -> signal association -mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem -mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName - (AST.NSimple signal) [AST.PrimName $ AST.NSimple index]))) +-- | Create an aggregate signal +mkAggregateSignal :: [AST.Expr] -> AST.Expr +mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x) mkComponentInst :: String -- ^ The portmap label @@ -117,7 +144,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins where -- We always have a clock port, so no need to map it anywhere but here clk_port = mkAssocElem clockId (idToVHDLExpr clockId) - compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port])) + resetn_port = mkAssocElem resetId (idToVHDLExpr resetId) + compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port])) ----------------------------------------------------------------------------- -- Functions to generate VHDL Exprs @@ -126,7 +154,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins varToVHDLExpr :: Var.Var -> TypeSession AST.Expr varToVHDLExpr var = do case Id.isDataConWorkId_maybe var of - Just dc -> return $ dataconToVHDLExpr dc + Just dc -> dataconToVHDLExpr dc -- This is a dataconstructor. -- Not a datacon, just another signal. Perhaps we should check for -- local/global here as well? @@ -156,23 +184,37 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core) -- Turn a alternative constructor into an AST expression. For -- dataconstructors, this is only the constructor itself, not any arguments it -- has. Should not be called with a DEFAULT constructor. -altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr +altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet" -altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" +altconToVHDLExpr DEFAULT = return $ AST.PrimLit "undefined" -- error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" -- Turn a datacon (without arguments!) into a VHDL expression. -dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr -dataconToVHDLExpr dc = AST.PrimLit lit - where - tycon = DataCon.dataConTyCon dc - tyname = TyCon.tyConName tycon - dcname = DataCon.dataConName dc - lit = case Name.getOccString tyname of - -- TODO: Do something more robust than string matching - "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" - "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false" +dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr +dataconToVHDLExpr dc = do + typemap <- getA tsTypes + htype_either <- mkHType (DataCon.dataConRepType dc) + case htype_either of + -- No errors + Right htype -> do + let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap + case existing_ty of + Just ty -> do + let dcname = DataCon.dataConName dc + let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname + return lit + Nothing -> do + let tycon = DataCon.dataConTyCon dc + let tyname = TyCon.tyConName tycon + let dcname = DataCon.dataConName dc + let lit = case Name.getOccString tyname of + -- TODO: Do something more robust than string matching + "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" + "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false" + return $ AST.PrimLit lit + -- Error when constructing htype + Left err -> error err ----------------------------------------------------------------------------- -- Functions dealing with names, variables and ids @@ -182,7 +224,10 @@ dataconToVHDLExpr dc = AST.PrimLit lit varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId -varToVHDLId = mkVHDLExtId . varToString +varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var)) + where + lowers :: String -> Int + lowers xs = length [x | x <- xs, Char.isLower x] -- Creates a VHDL Name from a binder varToVHDLName :: @@ -233,7 +278,7 @@ mkVHDLExtId s = AST.unsafeVHDLExtId $ strip_invalid s where -- Allowed characters, taken from ForSyde's mkVHDLExtId - allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-" + allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-" strip_invalid = filter (`elem` allowed) -- Create a record field selector that selects the given label from the record @@ -258,15 +303,16 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index]) -- for a few builtin types. builtin_types = Map.fromList [ - ("Bit", std_logicTM), - ("Bool", booleanTM), -- TysWiredIn.boolTy - ("Dec", integerTM) + ("Bit", Just std_logicTM), + ("Bool", Just booleanTM), -- TysWiredIn.boolTy + ("Dec", Just integerTM) ] -- Translate a Haskell type to a VHDL type, generating a new type if needed. -- Returns an error value, using the given message, when no type could be --- created. -vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark +-- created. Returns Nothing when the type is valid, but empty. +vhdl_ty :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession (Maybe AST.TypeMark) vhdl_ty msg ty = do tm_either <- vhdl_ty_either ty case tm_either of @@ -275,9 +321,17 @@ vhdl_ty msg ty = do -- Translate a Haskell type to a VHDL type, generating a new type if needed. -- Returns either an error message or the resulting type. -vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark) -vhdl_ty_either ty = do - typemap <- getA vsTypes +vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) => + t -> TypeSession (Either String (Maybe AST.TypeMark)) +vhdl_ty_either tything = + case getType tything of + Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything + Just ty -> vhdl_ty_either' ty + +vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) +vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty + | otherwise = do + typemap <- getA tsTypes htype_either <- mkHType ty case htype_either of -- No errors @@ -287,19 +341,22 @@ vhdl_ty_either ty = do let name = Name.getOccString (TyCon.tyConName tycon) Map.lookup name builtin_types -- If not a builtin type, try the custom types - let existing_ty = (fmap fst) $ Map.lookup htype typemap + let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of -- Found a type, return it Just t -> return (Right t) -- No type yet, try to construct it Nothing -> do - newty_maybe <- (construct_vhdl_ty ty) - case newty_maybe of - Right (ty_id, ty_def) -> do + newty_either <- (construct_vhdl_ty ty) + case newty_either of + Right newty -> do -- TODO: Check name uniqueness - modA vsTypes (Map.insert htype (ty_id, ty_def)) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) - return (Right ty_id) + modA tsTypes (Map.insert htype newty) + case newty of + Just (ty_id, ty_def) -> do + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + return (Right $ Just ty_id) + Nothing -> return $ Right Nothing Left err -> return $ Left $ "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" ++ err @@ -308,7 +365,9 @@ vhdl_ty_either ty = do -- Construct a new VHDL type for the given Haskell type. Returns an error -- message or the resulting typemark and typedef. -construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) +-- State types don't generate VHDL +construct_vhdl_ty ty | isStateType ty = return $ Right Nothing construct_vhdl_ty ty = do case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do @@ -325,7 +384,7 @@ construct_vhdl_ty ty = do Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") -- | Create VHDL type for a custom tycon -mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) mk_tycon_ty ty tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type @@ -339,23 +398,40 @@ mk_tycon_ty ty tycon args = elem_tys_either <- mapM vhdl_ty_either real_arg_tys case Either.partitionEithers elem_tys_either of -- No errors in element types - ([], elem_tys) -> do - let elems = zipWith AST.ElementDec recordlabels elem_tys - -- For a single construct datatype, build a record with one field for - -- each argument. - -- TODO: Add argument type ids to this, to ensure uniqueness - -- TODO: Special handling for tuples? - let elem_names = concat $ map prettyShow elem_tys - let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names - let ty_def = AST.TDR $ AST.RecordTypeDef elems - let tupshow = mkTupleShow elem_tys ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow) - return $ Right (ty_id, Left ty_def) + ([], elem_tys') -> do + -- Throw away all empty members + case Maybe.catMaybes elem_tys' of + [] -> -- No non-empty members + return $ Right Nothing + elem_tys -> do + let elems = zipWith AST.ElementDec recordlabels elem_tys + -- For a single construct datatype, build a record with one field for + -- each argument. + -- TODO: Add argument type ids to this, to ensure uniqueness + -- TODO: Special handling for tuples? + let elem_names = concat $ map prettyShow elem_tys + let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names + let ty_def = AST.TDR $ AST.RecordTypeDef elems + let tupshow = mkTupleShow elem_tys ty_id + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow) + return $ Right $ Just (ty_id, Left ty_def) -- There were errors in element types (errors, _) -> return $ Left $ "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat errors) - dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n" + dcs -> do + let arg_tys = concat $ map DataCon.dataConRepArgTys dcs + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + case real_arg_tys of + [] -> do + let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs + let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) + let ty_def = AST.TDE $ AST.EnumTypeDef elems + let enumShow = mkEnumShow elems ty_id + modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow) + return $ Right $ Just (ty_id, Left ty_def) + xs -> return $ Left $ + "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" where -- Create a subst that instantiates all types passed to the tycon -- TODO: I'm not 100% sure that this is the right way to do this. It seems @@ -368,12 +444,12 @@ mk_tycon_ty ty tycon args = -- | Create a VHDL vector type mk_vector_ty :: Type.Type -- ^ The Haskell type of the Vector - -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -- ^ An error message or The typemark created. mk_vector_ty ty = do - types_map <- getA vsTypes - env <- getA vsHscEnv + types_map <- getA tsTypes + env <- getA tsHscEnv let (nvec_l, nvec_el) = Type.splitAppTy ty let (nvec, leng) = Type.splitAppTy nvec_l let vec_ty = Type.mkAppTy nvec nvec_el @@ -382,23 +458,26 @@ mk_vector_ty ty = do el_ty_tm_either <- vhdl_ty_either el_ty case el_ty_tm_either of -- Could create element type - Right el_ty_tm -> do + Right (Just el_ty_tm) -> do let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map + let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map case existing_elem_ty of - Just t -> do + Just (Just t) -> do let ty_def = AST.SubtypeIn t (Just range) - return (Right (ty_id, Right ty_def)) + return (Right $ Just (ty_id, Right ty_def)) Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm - modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) - modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) + modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def)))) + modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) let vecShowFuns = mkVectorShow el_ty_tm vec_id - mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns + mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) - return (Right (ty_id, Right ty_def)) + return (Right $ Just (ty_id, Right ty_def)) + -- Empty element type? Empty vector type then. TODO: Does this make sense? + -- Probably needs changes in the builtin functions as well... + Right Nothing -> return $ Right Nothing -- Could not create element type Left err -> return $ Left $ "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" @@ -407,37 +486,34 @@ mk_vector_ty ty = do mk_natural_ty :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -- ^ An error message or The typemark created. mk_natural_ty min_bound max_bound = do - let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) - let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound)) - let ty_def = AST.SubtypeIn naturalTM (Just range) - return (Right (ty_id, Right ty_def)) + let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound))) + let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) + let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)] + let ty_def = AST.SubtypeIn unsignedTM (Just range) + return (Right $ Just (ty_id, Right ty_def)) mk_unsigned_ty :: Type.Type -- ^ Haskell type of the unsigned integer - -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) mk_unsigned_ty ty = do size <- tfp_to_int (sized_word_len_ty ty) let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn unsignedTM (Just range) - let unsignedshow = mkIntegerShow ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow) - return (Right (ty_id, Right ty_def)) + return (Right $ Just (ty_id, Right ty_def)) mk_signed_ty :: Type.Type -- ^ Haskell type of the signed integer - -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) mk_signed_ty ty = do size <- tfp_to_int (sized_int_len_ty ty) let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn signedTM (Just range) - let signedshow = mkIntegerShow ty_id - modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow) - return (Right (ty_id, Right ty_def)) + return (Right $ Just (ty_id, Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, -- which must result in a record type. @@ -447,11 +523,12 @@ getFieldLabels ty = do let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." vhdl_ty error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef - types <- getA vsTypes + types <- getA tsTypes -- Assume the type for which we want labels is really translatable Right htype <- mkHType ty case Map.lookup htype types of - Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Just Nothing -> return [] -- The type is empty _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem @@ -503,7 +580,7 @@ mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType) mkTyConHType tycon args = case TyCon.tyConDataCons tycon of -- Not an algebraic type - [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n" + [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n" [dc] -> do let arg_tys = DataCon.dataConRepArgTys dc let real_arg_tys = map (CoreSubst.substTy subst) arg_tys @@ -514,9 +591,16 @@ mkTyConHType tycon args = return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys -- There were errors in element types (errors, _) -> return $ Left $ - "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat errors) - dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n" + dcs -> do + let arg_tys = concat $ map DataCon.dataConRepArgTys dcs + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + case real_arg_tys of + [] -> + return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) + xs -> return $ Left $ + "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n" where tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) @@ -532,7 +616,7 @@ isReprType ty = do tfp_to_int :: Type.Type -> TypeSession Int tfp_to_int ty = do - hscenv <- getA vsHscEnv + hscenv <- getA tsHscEnv let norm_ty = normalise_tfp_int hscenv ty case Type.splitTyConApp_maybe norm_ty of Just (tycon, args) -> do @@ -542,21 +626,21 @@ tfp_to_int ty = do len <- tfp_to_int' ty return len otherwise -> do - modA vsTfpInts (Map.insert (OrdType norm_ty) (-1)) + modA tsTfpInts (Map.insert (OrdType norm_ty) (-1)) return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) tfp_to_int' :: Type.Type -> TypeSession Int tfp_to_int' ty = do - lens <- getA vsTfpInts - hscenv <- getA vsHscEnv + lens <- getA tsTfpInts + hscenv <- getA tsHscEnv let norm_ty = normalise_tfp_int hscenv ty let existing_len = Map.lookup (OrdType norm_ty) lens case existing_len of Just len -> return len Nothing -> do let new_len = eval_tfp_int hscenv ty - modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len)) + modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) return new_len mkTupleShow :: @@ -570,16 +654,30 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr] showExpr = AST.ReturnSm (Just $ AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'") where - showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $ - map ((genExprFCall showId). - AST.PrimName . - AST.NSelected . - (AST.NSimple tupPar AST.:.:). - tupVHDLSuffix) - (take tupSize recordlabels) + showMiddle = if null elemTMs then + AST.PrimLit "''" + else + foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $ + map ((genExprFCall showId). + AST.PrimName . + AST.NSelected . + (AST.NSimple tupPar AST.:.:). + tupVHDLSuffix) + (take tupSize recordlabels) recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] tupSize = length elemTMs +mkEnumShow :: + [AST.VHDLId] + -> AST.TypeMark + -> AST.SubProgBody +mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr] + where + enumPar = AST.unsafeVHDLBasicId "enum" + showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM + showExpr = AST.ReturnSm (Just $ + AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM)) + mkVectorShow :: AST.TypeMark -- ^ elemtype -> AST.TypeMark -- ^ vectype @@ -650,26 +748,19 @@ mkVectorShow elemTM vectorTM = genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&: AST.PrimLit "'>'" ) -mkIntegerShow :: - AST.TypeMark -- ^ The specific signed - -> AST.SubProgBody -mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr] - where - signedPar = AST.unsafeVHDLBasicId "sint" - showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM - showExpr = AST.ReturnSm (Just $ - AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) - (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing ) - where - signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar) - mkBuiltInShow :: [AST.SubProgBody] mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] , AST.SubProgBody showBoolSpec [] [showBoolExpr] + , AST.SubProgBody showSingedSpec [] [showSignedExpr] + , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr] + -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr] ] where - bitPar = AST.unsafeVHDLBasicId "s" - boolPar = AST.unsafeVHDLBasicId "b" + bitPar = AST.unsafeVHDLBasicId "s" + boolPar = AST.unsafeVHDLBasicId "b" + signedPar = AST.unsafeVHDLBasicId "sint" + unsignedPar = AST.unsafeVHDLBasicId "uint" + -- naturalPar = AST.unsafeVHDLBasicId "nat" showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM -- if s = '1' then return "'1'" else return "'0'" showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'") @@ -682,6 +773,23 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")] [] (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")]) + showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM + showSignedExpr = AST.ReturnSm (Just $ + AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) + (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing ) + where + signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar) + showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM + showUnsignedExpr = AST.ReturnSm (Just $ + AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) + (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing ) + where + unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar) + -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM + -- showNaturalExpr = AST.ReturnSm (Just $ + -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) + -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing ) + genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr genExprFCall fName args = @@ -693,11 +801,15 @@ genExprPCall2 entid arg1 arg2 = AST.ProcCall (AST.NSimple entid) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] -mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec) -mkSigDec bndr = - if True then do --isInternalSigUse use || isStateSigUse use then do - let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr) - return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) - else - return Nothing +mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec) +mkSigDec bndr = do + let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr + type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr) + case type_mark_maybe of + Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) + Nothing -> return Nothing + +-- | Does the given thing have a non-empty type? +hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => + t -> TranslatorSession Bool +hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)