Add a Type to a Literal SignalExpr.

[matthijs/master-project/cλash.git] / Flatten.hs

diff --git a/Flatten.hs b/Flatten.hs
index 8adce9fb0522f39780cc80aa8ac30e50b0a72e09..30a9bbabe9754911b551c9dad1e5ccc41d1e2401 100644 (file)
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -8,6 +8,7 @@ import qualified Maybe
 import qualified Control.Arrow as Arrow
 import qualified DataCon
 import qualified TyCon
+import qualified Literal
 import qualified CoreUtils
 import qualified TysWiredIn
 import qualified IdInfo
@@ -20,6 +21,7 @@ import qualified Control.Monad.Trans.State as State
 import HsValueMap
 import TranslatorTypes
 import FlattenTypes
+import CoreTools
 
 -- Extract the arguments from a data constructor application (that is, the
 -- normal args, leaving out the type args).
@@ -167,8 +169,11 @@ flattenExpr binds var@(Var id) =
           sig_id <- genSignalId SigInternal ty
           -- Add a name hint to the signal
           addNameHint (Name.getOccString id) sig_id
-          addDef (UncondDef (Right $ Literal lit) sig_id)
+          addDef (UncondDef (Right $ Literal lit Nothing) sig_id)
           return ([], Single sig_id)
+    IdInfo.VanillaGlobal ->
+      -- Treat references to globals as an application with zero elements
+      flattenApplicationExpr binds (CoreUtils.exprType var) id []
     otherwise ->
       error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
 
@@ -203,6 +208,20 @@ flattenExpr binds app@(App _ _) = do
         ([], b) <- flattenExpr binds (last args)
         res <- mkEqComparisons a b
         return ([], res)
+      else if fname == "fromInteger" then do
+        let [to_ty, to_dict, val] = args 
+        -- We assume this is an application of the GHC.Integer.smallInteger
+        -- function to a literal
+        let App smallint (Lit lit) = val
+        let (Literal.MachInt int) = lit
+        let ty = CoreUtils.exprType app
+        sig_id <- genSignalId SigInternal ty
+        -- TODO: fromInteger is defined for more types than just SizedWord
+        let len = sized_word_len ty
+        -- TODO: to_stdlogicvector doesn't work here, since SizedWord
+        -- translates to a different type...
+        addDef $ UncondDef (Right $ Literal ("to_stdlogicvector(to_unsigned(" ++ (show int) ++ ", " ++ (show len) ++ "))") Nothing) sig_id
+        return ([], Single sig_id)
       else
         flattenApplicationExpr binds (CoreUtils.exprType app) f args
   where
@@ -228,36 +247,6 @@ flattenExpr binds app@(App _ _) = do
       let res = Tuple arg_ress
       return ([], res)
 
-    -- | Flatten a normal application expression
-    flattenApplicationExpr binds ty f args = do
-      -- Find the function to call
-      let func = appToHsFunction ty f args
-      -- Flatten each of our args
-      flat_args <- (mapM (flattenExpr binds) args)
-      -- Check and split each of the arguments
-      let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
-      -- Generate signals for our result
-      res <- genSignals ty
-      -- Add name hints to the generated signals
-      let resname = Name.getOccString f ++ "_res"
-      Traversable.mapM (addNameHint resname) res
-      -- Create the function application
-      let app = FApp {
-        appFunc = func,
-        appArgs = arg_ress,
-        appRes  = res
-      }
-      addDef app
-      return ([], res)
-    -- | Check a flattened expression to see if it is valid to use as a
-    --   function argument. The first argument is the original expression for
-    --   use in the error message.
-    checkArg arg flat =
-      let (args, res) = flat in
-      if not (null args)
-        then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
-        else flat 
-
 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
   (b_args, b_res) <- flattenExpr binds bexpr
   if not (null b_args)
@@ -369,6 +358,36 @@ flattenExpr binds expr@(Case scrut b _ alts) = do
 flattenExpr _ expr = do
   error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
 
+-- | Flatten a normal application expression
+flattenApplicationExpr binds ty f args = do
+  -- Find the function to call
+  let func = appToHsFunction ty f args
+  -- Flatten each of our args
+  flat_args <- (mapM (flattenExpr binds) args)
+  -- Check and split each of the arguments
+  let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
+  -- Generate signals for our result
+  res <- genSignals ty
+  -- Add name hints to the generated signals
+  let resname = Name.getOccString f ++ "_res"
+  Traversable.mapM (addNameHint resname) res
+  -- Create the function application
+  let app = FApp {
+    appFunc = func,
+    appArgs = arg_ress,
+    appRes  = res
+  }
+  addDef app
+  return ([], res)
+-- | Check a flattened expression to see if it is valid to use as a
+--   function argument. The first argument is the original expression for
+--   use in the error message.
+checkArg arg flat =
+  let (args, res) = flat in
+  if not (null args)
+    then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
+    else flat 
+
 -- | Translates a dataconstructor without arguments to the corresponding
 --   literal.
 dataConToLiteral :: DataCon.DataCon -> FlattenState String