Added support for SizedInts and cleaned up some function related to SizedWords

diff --git a/Adders.hs b/Adders.hs
index aca64d3c229550415200cf047ebba8b8d4fb6ac8..cba5afed96519bb7c06f0c804b2fa0ed68de1593 100644 (file)
--- 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 3569d53b06e98b1c155cee605cd96e626067d69f..9c75bcc7b61caa6289fbec13e6e03257435e08ad 100644 (file)
--- 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 25fa899cea085f7a91fd530104bb15efa69ece3c..927749493ae7231d4a9bc6e8017ecae9d1a11190 100644 (file)
--- 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 ad36bbcb950a28f292b7dfb9fde20f87013d7712..85f790a6a979baac92c54a632f4798c86f2a8dfb 100644 (file)
--- 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 3a6060d302bc7a5f850bfeaa13d6532c15ffbc25..cf91cc7270fb45a9e844b437c254c770d22175ab 100644 (file)
--- 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 0bc1a5e339ef9cf32aa92554e1c30d12db972ff3..b9db66a485220276f060c18edcb9c1419efa1fa3 100644 (file)
--- 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)