From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Wed, 8 Jul 2009 13:21:41 +0000 (+0200)
Subject: VERY Ad-hoc support of literals.
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=c0b63b2aae039cecafb06bbcf63e50ee0359709b;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

VERY Ad-hoc support of literals.

Current implementation will probably fail in a lot of places
---

diff --git a/Constants.hs b/Constants.hs
index e8b0840..838f9c5 100644
--- a/Constants.hs
+++ b/Constants.hs
@@ -249,6 +249,9 @@ fromSizedWordId = "fromSizedWord"
 toIntegerId :: String
 toIntegerId = "to_integer"
 
+fromIntegerId :: String
+fromIntegerId = "fromInteger"
+
 ------------------
 -- VHDL type marks
 ------------------
diff --git a/CoreTools.hs b/CoreTools.hs
index 9c75bcc..443586b 100644
--- a/CoreTools.hs
+++ b/CoreTools.hs
@@ -27,6 +27,7 @@ import qualified VarSet
 import qualified Unique
 import qualified CoreUtils
 import qualified CoreFVs
+import qualified Literal
 
 -- Local imports
 import GhcTools
@@ -163,6 +164,10 @@ is_var :: CoreSyn.CoreExpr -> Bool
 is_var (CoreSyn.Var _) = True
 is_var _ = False
 
+is_lit :: CoreSyn.CoreExpr -> Bool
+is_lit (CoreSyn.Lit _) = True
+is_lit _ = False
+
 -- Can the given core expression be applied to something? This is true for
 -- applying to a value as well as a type.
 is_applicable :: CoreSyn.CoreExpr -> Bool
@@ -189,6 +194,11 @@ exprToVar :: CoreSyn.CoreExpr -> Var.Id
 exprToVar (CoreSyn.Var id) = id
 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
 
+-- Turns a Lit CoreExpr into the Literal inside it.
+exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
+exprToLit (CoreSyn.Lit lit) = lit
+exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
+
 -- Removes all the type and dictionary arguments from the given argument list,
 -- leaving only the normal value arguments. The type given is the type of the
 -- expression applied to this argument list.
@@ -200,3 +210,9 @@ get_val_args ty args = drop n args
     -- (length predtypes) arguments should be dictionaries. We drop this many
     -- arguments, to get at the value arguments.
     n = length tyvars + length predtypes
+
+getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
+getLiterals app@(CoreSyn.App _ _) = literals
+  where
+    (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+    literals = filter (is_lit) args
\ No newline at end of file
diff --git a/Generate.hs b/Generate.hs
index 97b8bef..bd7b482 100644
--- a/Generate.hs
+++ b/Generate.hs
@@ -17,6 +17,7 @@ import CoreSyn
 import Type
 import qualified Var
 import qualified IdInfo
+import qualified Literal
 
 -- Local imports
 import Constants
@@ -48,6 +49,18 @@ genVarArgs wrap dst func args = wrap dst func args'
     -- Check (rather crudely) that all arguments are CoreExprs
     (exprargs, []) = Either.partitionEithers args
 
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be Literals
+genLitArgs ::
+  (dst -> func -> [Literal.Literal] -> res)
+  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genLitArgs wrap dst func args = wrap dst func args'
+  where
+    args' = map exprToLit litargs
+    -- FIXME: Check if we were passed an CoreSyn.App
+    litargs = concat (map getLiterals exprargs)
+    (exprargs, []) = Either.partitionEithers args
+
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
 genExprRes ::
@@ -92,6 +105,15 @@ genFromSizedWord' (Left res) f args = do
              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
 
+-- FIXME: I'm calling genLitArgs which is very specific function,
+-- which needs to be fixed as well
+genFromInteger :: BuiltinBuilder
+genFromInteger = genLitArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
+genFromInteger' (Left res) f args = do
+  return $ AST.PrimLit (pprString (last args))
+genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder
@@ -938,4 +960,5 @@ globalNameTable = Map.fromList
   , (negateId         , (1, genOperator1 AST.Not    ) )
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
+  , (fromIntegerId    , (1, genFromInteger          ) )
   ]