From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Thu, 9 Jul 2009 14:22:24 +0000 (+0200)
Subject: Correctly handle negate for unsigned integers
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=7eb34cb0e082185b256b7231ee84cb04e006f51c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Correctly handle negate for unsigned integers
---

diff --git a/Generate.hs b/Generate.hs
index 947c222..a72cc62 100644
--- a/Generate.hs
+++ b/Generate.hs
@@ -85,6 +85,19 @@ genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator1' op _ f [arg] = return $ op arg
 
+-- | Generate a unary operator application
+genNegation :: BuiltinBuilder 
+genNegation = genVarArgs $ genExprRes genNegation'
+genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation' _ f [arg] = return $ op (varToVHDLExpr arg)
+  where
+    ty = Var.varType arg
+    (tycon, args) = Type.splitTyConApp ty
+    name = Name.getOccString (TyCon.tyConName tycon)
+    op = case name of
+      "SizedInt" -> AST.Neg
+      otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name 
+
 -- | Generate a function call from the destination binder, function name and a
 -- list of expressions (its arguments)
 genFCall :: Bool -> BuiltinBuilder 
@@ -971,7 +984,7 @@ globalNameTable = Map.fromList
   , (hwnotId          , (1, genOperator1 AST.Not    ) )
   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
-  , (negateId         , (1, genOperator1 AST.Neg    ) )
+  , (negateId         , (1, genNegation             ) )
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
diff --git a/Normalize.hs b/Normalize.hs
index 2ecf2fa..a299fd3 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -21,9 +21,11 @@ import CoreSyn
 import qualified UniqSupply
 import qualified CoreUtils
 import qualified Type
+import qualified TcType
 import qualified Id
 import qualified Var
 import qualified VarSet
+import qualified NameSet
 import qualified CoreFVs
 import qualified CoreUtils
 import qualified MkCore
@@ -512,6 +514,25 @@ normalizeBind bndr =
                 let used_funcs = VarSet.varSetElems used_funcs_set
                 -- Process each of the used functions recursively
                 mapM normalizeBind used_funcs
+                -- FIXME: Can't we inline these 'implicit' function calls or something?
+                -- TODO: Add an extra let expression to the current finding, so the VHDL
+                --       Will make a signa assignment for this 'implicit' function call
+                --
+                -- Find all the other free variables used that are used. This applies to
+                -- variables that are actually a reference to a Class function. Example:
+                --
+                -- functiontest :: SizedInt D8 -> SizedInt D8
+                -- functiontest = \a -> let r = a + 1 in r
+                --
+                -- The literal(Lit) '1' will be turned into a variable (Var)
+                -- As it will call the 'fromInteger' class function that belongs
+                -- to the Num class. So we need to translate the refenced function
+                -- let used_vars_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isAlgType . snd . Type.splitForAllTys . Id.idType) v) expr'
+                -- let used_vars = VarSet.varSetElems used_vars_set
+                -- -- Filter for dictionary args, they should not be translated
+                -- -- FIXME: check for other non-translatable stuff as well
+                -- let trans_vars = filter (\v -> (not . TcType.isDictTy . Id.idType) v) used_vars
+                -- mapM normalizeBind trans_vars
                 return ()
               -- We don't have a value for this binder. This really shouldn't
               -- happen for local id's...
diff --git "a/c\316\273ash.cabal" "b/c\316\273ash.cabal"
index 802557a..b5f497a 100644
--- "a/c\316\273ash.cabal"
+++ "b/c\316\273ash.cabal"
@@ -13,7 +13,7 @@ stability:           alpha
 maintainer:          christiaan.baaij@gmail.com & matthijs@stdin.nl
 build-depends:       base > 4, syb, ghc, ghc-paths, transformers, haskell98,
                      ForSyDe > 3.0, regex-posix ,data-accessor-template, pretty,
-                     data-accessor, containers, prettyclass, tfp > 0.3, 
+                     data-accessor, containers, prettyclass, tfp > 0.3.1, 
                      tfvec > 0.1.2, QuickCheck, template-haskell, filepath
 
 executable:          clash