From: Christiaan Baaij Date: Wed, 8 Jul 2009 12:20:10 +0000 (+0200) Subject: Added support for SizedInts and cleaned up some function related to SizedWords X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=78b45072fc36c7311bee97f2d9195bbc33b994cf Added support for SizedInts and cleaned up some function related to SizedWords --- diff --git a/Adders.hs b/Adders.hs index aca64d3..cba5afe 100644 --- a/Adders.hs +++ b/Adders.hs @@ -178,8 +178,8 @@ highordtest = \x -> xand a b = hwand a b -functiontest :: SizedWord D8 -> RangedWord D255 -functiontest = \a -> let r = fromSizedWord a in r +functiontest :: SizedInt D8 -> SizedInt D8 +functiontest = \a -> let r = a + (1 :: SizedInt D8) in r xhwnot x = hwnot x diff --git a/CoreTools.hs b/CoreTools.hs index 3569d53..9c75bcc 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -61,18 +61,38 @@ eval_tfp_int ty = -- | Get the width of a SizedWord type sized_word_len :: Type.Type -> Int -sized_word_len ty = - eval_tfp_int len - where - (tycon, args) = Type.splitTyConApp ty - [len] = args +sized_word_len ty = eval_tfp_int (sized_word_len_ty ty) + +sized_word_len_ty :: Type.Type -> Type.Type +sized_word_len_ty ty = len + where + args = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> args + Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty) + [len] = args + +-- | Get the width of a SizedInt type +sized_int_len :: Type.Type -> Int +sized_int_len ty = eval_tfp_int (sized_int_len_ty ty) + +sized_int_len_ty :: Type.Type -> Type.Type +sized_int_len_ty ty = len + where + args = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> args + Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty) + [len] = args -- | Get the upperbound of a RangedWord type ranged_word_bound :: Type.Type -> Int -ranged_word_bound ty = - eval_tfp_int len +ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty) + +ranged_word_bound_ty :: Type.Type -> Type.Type +ranged_word_bound_ty ty = len where - (tycon, args) = Type.splitTyConApp ty + args = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> args + Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty) [len] = args -- | Evaluate a core Type representing type level int from the TypeLevel diff --git a/Pretty.hs b/Pretty.hs index 25fa899..9277494 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -1,4 +1,4 @@ -module Pretty (prettyShow, pprString) where +module Pretty (prettyShow, pprString, pprStringDebug) where import qualified Data.Map as Map @@ -9,7 +9,7 @@ import qualified CoreSyn import qualified Module import qualified HscTypes import Text.PrettyPrint.HughesPJClass -import Outputable ( showSDoc, ppr, Outputable, OutputableBndr) +import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr) import qualified ForSyDe.Backend.Ppr import qualified ForSyDe.Backend.VHDL.Ppr @@ -158,3 +158,6 @@ instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where -- Convenience method for turning an Outputable into a string pprString :: (Outputable x) => x -> String pprString = showSDoc . ppr + +pprStringDebug :: (Outputable x) => x -> String +pprStringDebug = showSDocDebug . ppr diff --git a/Translator.hs b/Translator.hs index ad36bbc..85f790a 100644 --- a/Translator.hs +++ b/Translator.hs @@ -26,7 +26,7 @@ import NameEnv ( lookupNameEnv ) import qualified HscTypes import HscTypes ( cm_binds, cm_types ) import MonadUtils ( liftIO ) -import Outputable ( showSDoc, ppr ) +import Outputable ( showSDoc, ppr, showSDocDebug ) import GHC.Paths ( libdir ) import DynFlags ( defaultDynFlags ) import qualified UniqSupply @@ -65,6 +65,24 @@ makeVHDL filename name stateful = do mapM (writeVHDL dir) vhdl return () +listBindings :: String -> IO [()] +listBindings filename = do + core <- loadModule filename + let binds = CoreSyn.flattenBinds $ cm_binds core + mapM (listBinding) binds + +listBinding :: (CoreBndr, CoreExpr) -> IO () +listBinding (b, e) = do + putStr "\nBinder: " + putStr $ show b + putStr "\nExpression: \n" + putStr $ prettyShow e + putStr "\n\n" + putStr $ showSDoc $ ppr e + putStr "\n\n" + putStr $ showSDoc $ ppr $ CoreUtils.exprType e + putStr "\n\n" + -- | Show the core structure of the given binds in the given file. listBind :: String -> String -> IO () listBind filename name = do diff --git a/VHDLTools.hs b/VHDLTools.hs index 3a6060d..cf91cc7 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -20,6 +20,7 @@ import qualified Name import qualified OccName import qualified Var import qualified Id +import qualified IdInfo import qualified TyCon import qualified Type import qualified DataCon @@ -143,6 +144,7 @@ varToVHDLExpr var = in res + -- Turn a VHDLName into an AST expression vhdlNameToVHDLExpr = AST.PrimName @@ -315,6 +317,7 @@ construct_vhdl_ty ty = do case name of "TFVec" -> mk_vector_ty ty "SizedWord" -> mk_unsigned_ty ty + "SizedInt" -> mk_signed_ty ty "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty) -- Create a custom type from this tycon otherwise -> mk_tycon_ty tycon args @@ -407,12 +410,22 @@ mk_natural_ty min_bound max_bound = do return (Right (ty_id, Right ty_def)) mk_unsigned_ty :: - Type.Type -- ^ Haskell type of the signed integer + Type.Type -- ^ Haskell type of the unsigned integer -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) mk_unsigned_ty ty = do let size = sized_word_len 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) + return (Right (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)) +mk_signed_ty ty = do + let size = sized_word_len 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) return (Right (ty_id, Right ty_def)) @@ -456,14 +469,21 @@ mkHType ty = do case elem_htype_either of -- Could create element type Right elem_htype -> do - len <- vec_len ty + len <- tfp_to_int (tfvec_len_ty ty) return $ Right $ VecType len elem_htype -- Could not create element type Left err -> return $ Left $ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" ++ err - "SizedWord" -> return $ Right $ StdType $ OrdType ty - "RangedWord" -> return $ Right $ StdType $ OrdType ty + "SizedWord" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedWType len + "SizedInt" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedIType len + "RangedWord" -> do + bound <- tfp_to_int (ranged_word_bound_ty ty) + return $ Right $ RangedWType bound otherwise -> do mkTyConHType tycon args Nothing -> return $ Right $ StdType $ OrdType ty @@ -499,14 +519,13 @@ isReprType ty = do Left _ -> False Right _ -> True -vec_len :: Type.Type -> TypeSession Int -vec_len ty = do - veclens <- getA vsTfpInts - let len_ty = tfvec_len_ty ty - let existing_len = Map.lookup (OrdType len_ty) veclens +tfp_to_int :: Type.Type -> TypeSession Int +tfp_to_int ty = do + lens <- getA vsTfpInts + let existing_len = Map.lookup (OrdType ty) lens case existing_len of Just len -> return len Nothing -> do - let new_len = tfvec_len ty - modA vsTfpInts (Map.insert (OrdType len_ty) (new_len)) + let new_len = eval_tfp_int ty + modA vsTfpInts (Map.insert (OrdType ty) (new_len)) return new_len \ No newline at end of file diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 0bc1a5e..b9db66a 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -41,6 +41,9 @@ instance Ord OrdType where data HType = StdType OrdType | ADTType String [HType] | VecType Int HType | + SizedWType Int | + RangedWType Int | + SizedIType Int | BuiltinType String deriving (Eq, Ord)