From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Tue, 13 Apr 2010 12:40:17 +0000 (+0200)
Subject: Rewrite fromInteger and literal generation.
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=8663a3e3f2776039a31528c3087ef5725d401932;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Rewrite fromInteger and literal generation.

Literals are less of a hack now and should work more reliably.
---

diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
index 9ac0fdf..0959570 100644
--- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs"
@@ -9,6 +9,7 @@ module CLasH.Utils.Core.CoreTools where
 import qualified Maybe
 import qualified System.IO.Unsafe
 import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
 
 -- GHC API
 import qualified GHC
@@ -261,21 +262,27 @@ get_val_args ty args = drop n args
     -- arguments, to get at the value arguments.
     n = length tyvars + length predtypes
 
-getLiterals :: HscTypes.HscEnv -> CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-getLiterals _ app@(CoreSyn.App _ _) = literals
-  where
-    (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-    literals = filter (is_lit) args
-
-getLiterals _ lit@(CoreSyn.Lit _) = [lit]
-
-getLiterals hscenv letrec@(CoreSyn.Let (CoreSyn.NonRec letBind (letExpr)) letRes) = [lit]
-  where
-    ty     = Var.varType letBind
-    litInt = eval_tfp_int hscenv ty
-    lit    = CoreSyn.Lit (Literal.mkMachInt (toInteger litInt))
-
-getLiterals _ expr = error $ "\nCoreTools.getLiterals: Not a known Lit: " ++ pprString expr
+-- Finds out what literal Integer this expression represents.
+getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer
+getIntegerLiteral expr =
+  case CoreSyn.collectArgs expr of
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)]) 
+      | getFullString f == "GHC.Integer.smallInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)]) 
+      | getFullString f == "GHC.Integer.int64ToInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)]) 
+      | getFullString f == "GHC.Integer.wordToInteger" -> return integer
+    (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)]) 
+      | getFullString f == "GHC.Integer.word64ToInteger" -> return integer
+    -- fromIntegerT returns the integer corresponding to the type of its
+    -- (third) argument. Since it is polymorphic, the type of that
+    -- argument is passed as the first argument, so we can just use that
+    -- one.
+    (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg]) 
+      | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do
+          int <- MonadState.lift tsType $ tfp_to_int dec_ty
+          return $ toInteger int
+    _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr
 
 reduceCoreListToHsList :: 
   [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index 07cf0e8..0c1f2d7 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -359,19 +359,6 @@ genCoreArgs wrap dst func args = wrap dst func args'
       (exprargs, []) -> exprargs
       (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
 
--- | A function to wrap a builder-like function that expects its arguments to
--- be Literals
-genLitArgs ::
-  (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
-  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
-genLitArgs wrap dst func args = do
-  hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
-  let (exprargs, []) = Either.partitionEithers args
-  -- FIXME: Check if we were passed an CoreSyn.App
-  let litargs = concatMap (getLiterals hscenv) exprargs
-  let args' = map exprToLit litargs
-  wrap dst func args'   
-
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
 genExprRes ::
@@ -480,28 +467,29 @@ genTimes' (Left res) f [arg1,arg2] = do {
   }
 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
--- FIXME: I'm calling genLitArgs which is very specific function,
--- which needs to be fixed as well
+-- fromInteger turns an Integer into a Num instance. Since Integer is
+-- not representable and is only allowed for literals, the actual
+-- Integer should be inlined entirely into the fromInteger argument.
 genFromInteger :: BuiltinBuilder
-genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
-genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
-genFromInteger' (Left res) f lits = do {
-  ; let { ty = Var.varType res
-        ; (tycon, args) = Type.splitTyConApp ty
-        ; name = Name.getOccString (TyCon.tyConName tycon)
-        } ;
-  ; len <- case name of
+genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
+genFromInteger' (Left res) f args = do
+  let ty = Var.varType res
+  let (tycon, tyargs) = Type.splitTyConApp ty
+  let name = Name.getOccString (TyCon.tyConName tycon)
+  len <- case name of
     "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
     "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
-    "RangedWord" -> do {
-      ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
-      ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
-      }
-  ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
-  ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
-            [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
-
-  }
+    "RangedWord" -> do
+      bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+      return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
+  let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
+  case args of
+    [integer] -> do -- The type and dictionary arguments are removed by genApplication
+      literal <- getIntegerLiteral integer
+      return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+              [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+    _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name