X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=716663025e9698753f3a3ce55be5c366f74fba7d;hb=470b9fcfe0743054e2a1adb435e2806a140c732e;hp=546fc124ffd216b7e105340b64172fcc423e895d;hpb=466f80bdde9511508c38e951d208a2a52c90c7da;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 546fc12..7166630 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -8,23 +8,17 @@ 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 -import qualified Control.Monad.Trans.State as State -import qualified Data.Monoid as Monoid -import Data.Accessor -import Data.Accessor.MonadState as MonadState -import Debug.Trace - --- ForSyDe +import qualified Data.Accessor.Monad.Trans.State as MonadState + +-- VHDL Imports import qualified Language.VHDL.AST as AST -- GHC API -import CoreSyn +import qualified CoreSyn import qualified Name import qualified OccName import qualified Var import qualified Id -import qualified IdInfo import qualified TyCon import qualified Type import qualified DataCon @@ -45,14 +39,14 @@ import CLasH.VHDL.Constants -- Create an unconditional assignment statement mkUncondAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The expression to assign -> AST.ConcSm -- ^ The resulting concurrent statement mkUncondAssign dst expr = mkAssign dst Nothing expr -- Create a conditional assignment statement mkCondAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The condition -> AST.Expr -- ^ The value when true -> AST.Expr -- ^ The value when false @@ -61,7 +55,7 @@ mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false -- Create a conditional or unconditional assignment statement mkAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for -- and the value to assign when true. -> AST.Expr -- ^ The value to assign when false or no condition @@ -86,12 +80,12 @@ mkAssign dst cond false_expr = AST.CSSASm assign mkAltsAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.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" + | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch" | otherwise = let whenelses = zipWith mkWhenElse conds exprs @@ -152,25 +146,12 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins ----------------------------------------------------------------------------- varToVHDLExpr :: Var.Var -> TypeSession AST.Expr -varToVHDLExpr var = do +varToVHDLExpr var = case Id.isDataConWorkId_maybe var of - Just dc -> dataconToVHDLExpr dc -- This is a dataconstructor. - -- Not a datacon, just another signal. Perhaps we should check for - -- local/global here as well? - -- Sadly so.. tfp decimals are types, not data constructors, but instances - -- should still be translated to integer literals. It is probebly not the - -- best solution to translate them here. - -- FIXME: Find a better solution for translating instances of tfp integers - Nothing -> do - let ty = Var.varType var - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> - case Name.getOccString (TyCon.tyConName tycon) of - "Dec" -> do - len <- tfp_to_int ty - return $ AST.PrimLit $ (show len) - otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var + Just dc -> dataconToVHDLExpr dc + -- Not a datacon, just another signal. + Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var -- Turn a VHDLName into an AST expression vhdlNameToVHDLExpr = AST.PrimName @@ -185,15 +166,15 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core) -- dataconstructors, this is only the constructor itself, not any arguments it -- has. Should not be called with a DEFAULT constructor. altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr -altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc +altconToVHDLExpr (CoreSyn.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 (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet" +altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" -- Turn a datacon (without arguments!) into a VHDL expression. dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr dataconToVHDLExpr dc = do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes htype_either <- mkHTypeEither (DataCon.dataConRepType dc) case htype_either of -- No errors @@ -203,7 +184,7 @@ dataconToVHDLExpr dc = do (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false" otherwise -> do - let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap + let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap case existing_ty of Just ty -> do let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname @@ -220,7 +201,7 @@ dataconToVHDLExpr dc = do varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId -varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var)) +varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var)) where lowers :: String -> Int lowers xs = length [x | x <- xs, Char.isLower x] @@ -259,7 +240,7 @@ mkVHDLBasicId s = -- Strip leading numbers and underscores strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_") -- Strip multiple adjacent underscores - strip_multiscore = concat . map (\cs -> + strip_multiscore = concatMap (\cs -> case cs of ('_':_) -> "_" _ -> cs @@ -298,8 +279,7 @@ builtin_types :: TypeMap builtin_types = Map.fromList [ (BuiltinType "Bit", Just (std_logicTM, Nothing)), - (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy - (BuiltinType "Dec", Just (integerTM, Nothing)) + (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy ] -- Is the given type representable at runtime? @@ -310,6 +290,8 @@ isReprType ty = do Left _ -> False Right _ -> True +-- | Turn a Core type into a HType, returning an error using the given +-- error string if the type was not representable. mkHType :: (TypedThing t, Outputable.Outputable t) => String -> t -> TypeSession HType mkHType msg ty = do @@ -318,9 +300,11 @@ mkHType msg ty = do Right htype -> return htype Left err -> error $ msg ++ err +-- | Turn a Core type into a HType. Returns either an error message if +-- the type was not representable, or the HType generated. mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => t -> TypeSession (Either String HType) -mkHTypeEither tything = do +mkHTypeEither tything = case getType tything of Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything Just ty -> mkHTypeEither' ty @@ -328,15 +312,15 @@ mkHTypeEither tything = do mkHTypeEither' :: Type.Type -> TypeSession (Either String HType) mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty | isStateType ty = return $ Right StateType - | otherwise = do + | otherwise = case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes let name = Name.getOccString (TyCon.tyConName tycon) let builtinTyMaybe = Map.lookup (BuiltinType name) typemap case builtinTyMaybe of (Just x) -> return $ Right $ BuiltinType name - Nothing -> do + Nothing -> case name of "TFVec" -> do let el_ty = tfvec_elem ty @@ -358,7 +342,7 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType "RangedWord" -> do bound <- tfp_to_int (ranged_word_bound_ty ty) return $ Right $ RangedWType bound - otherwise -> do + otherwise -> mkTyConHType tycon args Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty @@ -373,17 +357,17 @@ mkTyConHType tycon args = let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate case Either.partitionEithers elem_htys_either of - ([], [elem_hty]) -> do + ([], [elem_hty]) -> return $ Right elem_hty -- No errors in element types - ([], elem_htys) -> do + ([], elem_htys) -> return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys -- There were errors in element types (errors, _) -> return $ Left $ "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" ++ (concat errors) dcs -> do - let arg_tys = concat $ map DataCon.dataConRepArgTys dcs + let arg_tys = concatMap DataCon.dataConRepArgTys dcs let real_arg_tys = map (CoreSubst.substTy subst) arg_tys case real_arg_tys of [] -> @@ -401,12 +385,11 @@ vhdlTy :: (TypedThing t, Outputable.Outputable t) => String -> t -> TypeSession (Maybe AST.TypeMark) vhdlTy msg ty = do htype <- mkHType msg ty - tm <- vhdlTyMaybe htype - return tm + vhdlTyMaybe htype vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) vhdlTyMaybe htype = do - typemap <- getA tsTypes + typemap <- MonadState.get tsTypes -- If not a builtin type, try the custom types let existing_ty = Map.lookup htype typemap case existing_ty of @@ -416,10 +399,10 @@ vhdlTyMaybe htype = do -- No type yet, try to construct it Nothing -> do newty <- (construct_vhdl_ty htype) - modA tsTypes (Map.insert htype newty) + MonadState.modify tsTypes (Map.insert htype newty) case newty of Just (ty_id, ty_def) -> do - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) return $ Just ty_id Nothing -> return Nothing @@ -427,7 +410,7 @@ vhdlTyMaybe htype = do -- message or the resulting typemark and typedef. construct_vhdl_ty :: HType -> TypeSession TypeMapRec -- State types don't generate VHDL -construct_vhdl_ty htype = do +construct_vhdl_ty htype = case htype of StateType -> return Nothing (SizedWType w) -> mkUnsignedTy w @@ -448,18 +431,18 @@ mkTyconTy htype = return Nothing elem_tys -> do let elems = zipWith AST.ElementDec recordlabels elem_tys - let elem_names = concat $ map prettyShow elem_tys + let elem_names = concatMap prettyShow elem_tys let ty_id = mkVHDLExtId $ tycon ++ elem_names let ty_def = AST.TDR $ AST.RecordTypeDef elems let tupshow = mkTupleShow elem_tys ty_id - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do let elems = map mkVHDLExtId dcs let ty_id = mkVHDLExtId tycon let ty_def = AST.TDE $ AST.EnumTypeDef elems let enumShow = mkEnumShow elems ty_id - modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) return $ Just (ty_id, Just $ Left ty_def) otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype where @@ -473,13 +456,13 @@ mkVectorTy :: -- ^ An error message or The typemark created. mkVectorTy (VecType len elHType) = do - typesMap <- getA tsTypes + typesMap <- MonadState.get tsTypes elTyTmMaybe <- vhdlTyMaybe elHType case elTyTmMaybe of (Just elTyTm) -> do let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap + let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap case existing_uvec_ty of Just (Just t) -> do let ty_def = AST.SubtypeIn t (Just range) @@ -487,12 +470,13 @@ mkVectorTy (VecType len elHType) = do Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm - modA tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) + MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) let vecShowFuns = mkVectorShow elTyTm vec_id - mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns + mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) return (Just (ty_id, Just $ Right ty_def)) + -- Vector of empty elements becomes empty itself. Nothing -> return Nothing mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype @@ -534,48 +518,20 @@ getFieldLabels ty = do let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." vhdlTy error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef - types <- getA tsTypes + types <- MonadState.get tsTypes -- Assume the type for which we want labels is really translatable htype <- mkHType error_msg ty case Map.lookup htype types of - Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype) Just Nothing -> return [] -- The type is empty - _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype) + Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems + 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) mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem mytydecl (_, Nothing) = Nothing mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def -tfp_to_int :: Type.Type -> TypeSession Int -tfp_to_int ty = do - hscenv <- getA tsHscEnv - let norm_ty = normalise_tfp_int hscenv ty - case Type.splitTyConApp_maybe norm_ty of - Just (tycon, args) -> do - let name = Name.getOccString (TyCon.tyConName tycon) - case name of - "Dec" -> do - len <- tfp_to_int' ty - return len - otherwise -> do - 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 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 tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) - return new_len - mkTupleShow :: [AST.TypeMark] -- ^ type of each tuple element -> AST.TypeMark -- ^ type of the tuple @@ -625,7 +581,7 @@ mkVectorShow elemTM vectorTM = resId = AST.unsafeVHDLBasicId "res" headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM -- return vec(0); - headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName + headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimLit "0"]))) vecSlice init last = AST.PrimName (AST.NSlice (AST.SliceName @@ -711,13 +667,13 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] 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) + 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) + 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)