X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=8d2d5b62b50053c96afb4b384b0ebd6ce3b66341;hb=ed1bae43e489cc20a6be9dd5e007bb7d7b6a95dc;hp=325f742bec2970155ad53093a04354324c7a62a4;hpb=1916a5498a667b3d1cd4321d555ab40c0a55de00;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Flatten.hs b/Flatten.hs
index 325f742..8d2d5b6 100644
--- 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
@@ -15,7 +16,7 @@ import qualified Data.Traversable as Traversable
 import qualified Data.Foldable as Foldable
 import Control.Applicative
 import Outputable ( showSDoc, ppr )
-import qualified Control.Monad.State as State
+import qualified Control.Monad.Trans.State as State
 
 import HsValueMap
 import TranslatorTypes
@@ -169,6 +170,9 @@ flattenExpr binds var@(Var id) =
           addNameHint (Name.getOccString id) sig_id
           addDef (UncondDef (Right $ Literal lit) 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)
 
@@ -222,42 +226,12 @@ flattenExpr binds app@(App _ _) = do
 
     flattenBuildTupleExpr binds args = do
       -- Flatten each of our args
-      flat_args <- (State.mapM (flattenExpr binds) args)
+      flat_args <- (mapM (flattenExpr binds) args)
       -- Check and split each of the arguments
       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
       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 <- (State.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)
@@ -331,25 +305,20 @@ flattenExpr binds expr@(Case scrut b _ alts) = do
       (args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts)
       case a of
         (DataAlt datacon, bind_vars, expr) -> do
-          if isDontCare datacon 
-            then do
-              -- Completely skip the dontcare cases
-              return (args', res')
-            else do
-              lit <- dataConToLiteral datacon
-              -- The scrutinee must be a single signal
-              let Single sig = scrut
-              -- Create a signal that contains a boolean
-              boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
-              addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid
-              let expr = EqLit sig lit
-              addDef (UncondDef (Right expr) boolsigid)
-              -- Create conditional assignments of either args/res or
-              -- args'/res based on boolsigid, and return the result.
-              -- TODO: It seems this adds the name hint twice?
-              our_args <- Monad.zipWithM (mkConditionals boolsigid) args args'
-              our_res  <- mkConditionals boolsigid res res'
-              return (our_args, our_res)
+          lit <- dataConToLiteral datacon
+          -- The scrutinee must be a single signal
+          let Single sig = scrut
+          -- Create a signal that contains a boolean
+          boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
+          addNameHint ("s" ++ show sig ++ "_eq_" ++ lit) boolsigid
+          let expr = EqLit sig lit
+          addDef (UncondDef (Right expr) boolsigid)
+          -- Create conditional assignments of either args/res or
+          -- args'/res based on boolsigid, and return the result.
+          -- TODO: It seems this adds the name hint twice?
+          our_args <- Monad.zipWithM (mkConditionals boolsigid) args args'
+          our_res  <- mkConditionals boolsigid res res'
+          return (our_args, our_res)
         otherwise ->
           error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
       where
@@ -374,19 +343,35 @@ flattenExpr binds expr@(Case scrut b _ alts) = do
 flattenExpr _ expr = do
   error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
 
--- | Is the given data constructor a dontcare?
-isDontCare :: DataCon.DataCon -> Bool
-isDontCare datacon =
-  case Name.getOccString tyname of
-    -- TODO: Do something more robust than string matching
-    "Bit" ->
-      Name.getOccString dcname  == "DontCare"
-    otherwise ->
-      False
-  where
-    tycon = DataCon.dataConTyCon datacon
-    tyname = TyCon.tyConName tycon
-    dcname = DataCon.dataConName datacon
+-- | 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.
@@ -398,7 +383,7 @@ dataConToLiteral datacon = do
     -- TODO: Do something more robust than string matching
     "Bit"      -> do
       let dcname = DataCon.dataConName datacon
-      let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"; "DontCare" -> "'-'"
+      let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
       return lit
     "Bool" -> do
       let dcname = DataCon.dataConName datacon