From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Tue, 7 Jul 2009 12:39:16 +0000 (+0200)
Subject: Started adding numeric operations
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=8782caddd5cc4df0c68e4025266c9b558e32eb48;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Started adding numeric operations
---

diff --git a/Adders.hs b/Adders.hs
index 94184b0..aca64d3 100644
--- a/Adders.hs
+++ b/Adders.hs
@@ -13,6 +13,8 @@ import Language.Haskell.Syntax
 import Types
 import Data.Param.TFVec
 import Data.RangedWord
+import Data.SizedInt
+import Data.SizedWord
 
 mainIO f = Sim.simulateIO (Sim.stateless f) ()
 
@@ -176,8 +178,8 @@ highordtest = \x ->
 
 xand a b = hwand a b
 
-functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit)
-functiontest = \v -> let r = (concat v, head v) in r
+functiontest :: SizedWord D8 -> RangedWord D255
+functiontest = \a -> let r = fromSizedWord a in r
 
 xhwnot x = hwnot x
 
diff --git a/Constants.hs b/Constants.hs
index af8c324..e8b0840 100644
--- a/Constants.hs
+++ b/Constants.hs
@@ -224,6 +224,31 @@ hwandId = "hwand"
 lengthTId :: String
 lengthTId = "lengthT"
 
+-- Numeric Operations
+
+-- | plus operation identifier
+plusId :: String
+plusId = "+"
+
+-- | times operation identifier
+timesId :: String
+timesId = "*"
+
+-- | negate operation identifier
+negateId :: String
+negateId = "negate"
+
+-- | minus operation identifier
+minusId :: String
+minusId = "-"
+
+-- | convert sizedword to ranged
+fromSizedWordId :: String
+fromSizedWordId = "fromSizedWord"
+
+toIntegerId :: String
+toIntegerId = "to_integer"
+
 ------------------
 -- VHDL type marks
 ------------------
@@ -251,3 +276,11 @@ naturalTM = AST.unsafeVHDLBasicId "natural"
 -- | integer TypeMark
 integerTM :: AST.TypeMark
 integerTM = AST.unsafeVHDLBasicId "integer"
+
+-- | signed TypeMark
+signedTM :: AST.TypeMark
+signedTM = AST.unsafeVHDLBasicId "signed"
+
+-- | unsigned TypeMark
+unsignedTM :: AST.TypeMark
+unsignedTM = AST.unsafeVHDLBasicId "unsigned"
diff --git a/Generate.hs b/Generate.hs
index b3045de..97b8bef 100644
--- a/Generate.hs
+++ b/Generate.hs
@@ -83,6 +83,16 @@ genFCall' switch (Left res) f args = do
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
+genFromSizedWord :: BuiltinBuilder
+genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFromSizedWord' (Left res) f args = do
+  let fname = varToString f
+  return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
+             map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder
 genMap (Left res) f [Left mapped_f, Left (Var arg)] =
@@ -440,8 +450,8 @@ genApplication dst f args =
           if length args == arg_count then
             builder dst f args
           else
-            error $ "\nGenerate.genApplication: Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-        Nothing -> error $ "\nGenerate.genApplication: Using function from another module that is not a known builtin: " ++ pprString f
+            error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+        Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
     IdInfo.NotGlobalId -> do
       signatures <- getA vsSignatures
       -- This is a local id, so it should be a function whose definition we
@@ -457,6 +467,16 @@ genApplication dst f args =
         portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
         in
           return [mkComponentInst label entity_id portmaps]
+    IdInfo.ClassOpId cls -> do
+      -- FIXME: Not looking for what instance this class op is called for
+      -- Is quite stupid of course.
+      case (Map.lookup (varToString f) globalNameTable) of
+        Just (arg_count, builder) ->
+          if length args == arg_count then
+            builder dst f args
+          else
+            error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+        Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
     details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 
 -----------------------------------------------------------------------------
@@ -913,4 +933,9 @@ globalNameTable = Map.fromList
   , (hwandId          , (2, genOperator2 AST.And    ) )
   , (hworId           , (2, genOperator2 AST.Or     ) )
   , (hwnotId          , (1, genOperator1 AST.Not    ) )
+  , (plusId           , (2, genOperator2 (AST.:+:)  ) )
+  , (timesId          , (2, genOperator2 (AST.:*:)  ) )
+  , (negateId         , (1, genOperator1 AST.Not    ) )
+  , (minusId          , (2, genOperator2 (AST.:-:)  ) )
+  , (fromSizedWordId  , (1, genFromSizedWord        ) )
   ]
diff --git a/VHDLTools.hs b/VHDLTools.hs
index e4aad6f..3a6060d 100644
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -314,9 +314,7 @@ construct_vhdl_ty ty = do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
         "TFVec" -> mk_vector_ty ty
-        -- "SizedWord" -> do
-        --   res <- mk_vector_ty (sized_word_len ty) ty
-        --   return $ Just $ (Arrow.second Left) res
+        "SizedWord" -> mk_unsigned_ty ty
         "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
@@ -408,6 +406,16 @@ mk_natural_ty min_bound max_bound = do
   let ty_def = AST.SubtypeIn naturalTM (Just range)
   return (Right (ty_id, Right ty_def))
 
+mk_unsigned_ty ::
+  Type.Type -- ^ Haskell type of the signed 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 signedTM (Just range)
+  return (Right (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.
 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
@@ -454,6 +462,8 @@ mkHType ty = do
                 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
             otherwise -> do
               mkTyConHType tycon args
         Nothing -> return $ Right $ StdType $ OrdType ty