X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=11738c70f5803509056662013ee711b6fec93c54;hb=c0fa1614f8bb0126868658fad79b01df447e113a;hp=5ffd16263ffe395ca3adebfff4abc72eb7f9e493;hpb=1e30fe04f4c285970ad2d5e23930dd935b4214fa;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Flatten.hs b/Flatten.hs
index 5ffd162..11738c7 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -1,6 +1,6 @@
 module Flatten where
 import CoreSyn
-import Control.Monad
+import qualified Control.Monad as Monad
 import qualified Var
 import qualified Type
 import qualified Name
@@ -10,6 +10,7 @@ import qualified DataCon
 import qualified TyCon
 import qualified CoreUtils
 import qualified TysWiredIn
+import qualified IdInfo
 import qualified Data.Traversable as Traversable
 import qualified Data.Foldable as Foldable
 import Control.Applicative
@@ -137,18 +138,34 @@ flattenExpr binds lam@(Lam b expr) = do
   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
   -- Create signal names for the binder
   defs <- genSignals arg_ty
+  -- Add name hints to the generated signals
+  let binder_name = Name.getOccString b
+  Traversable.mapM (addNameHint binder_name) defs
   let binds' = (b, Left defs):binds
   (args, res) <- flattenExpr binds' expr
   return (defs : args, res)
 
-flattenExpr binds (Var id) =
-  case bind of
-    Left sig_use -> return ([], sig_use)
-    Right _ -> error "Higher order functions not supported."
-  where
-    bind = Maybe.fromMaybe
-      (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
-      (lookup id binds)
+flattenExpr binds var@(Var id) =
+  case Var.globalIdVarDetails id of
+    IdInfo.NotGlobalId ->
+      let 
+        bind = Maybe.fromMaybe
+          (error $ "Local value " ++ Name.getOccString id ++ " is unknown")
+          (lookup id binds) 
+      in
+        case bind of
+          Left sig_use -> return ([], sig_use)
+          Right _ -> error "Higher order functions not supported."
+    IdInfo.DataConWorkId datacon -> do
+      lit <- dataConToLiteral datacon
+      let ty = CoreUtils.exprType var
+      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)
+      return ([], Single sig_id)
+    otherwise ->
+      error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id)
 
 flattenExpr binds app@(App _ _) = do
   -- Is this a data constructor application?
@@ -162,8 +179,42 @@ flattenExpr binds app@(App _ _) = do
     otherwise ->
       -- Normal function application
       let ((Var f), args) = collectArgs app in
-      flattenApplicationExpr binds (CoreUtils.exprType app) f args
+      let fname = Name.getOccString f in
+      if fname == "fst" || fname == "snd" then do
+        (args', Tuple [a, b]) <- flattenExpr binds (last args)
+        return (args', if fname == "fst" then a else b)
+      else if fname == "patError" then do
+        -- This is essentially don't care, since the program will error out
+        -- here. We'll just define undriven signals here.
+        let (argtys, resty) = Type.splitFunTys $ CoreUtils.exprType app
+        args <- mapM genSignals argtys
+        res <- genSignals resty
+        mapM (Traversable.mapM (addNameHint "NC")) args
+        Traversable.mapM (addNameHint "NC") res
+        return (args, res)
+      else if fname == "==" then do
+        -- Flatten the last two arguments (this skips the type arguments)
+        ([], a) <- flattenExpr binds (last $ init args)
+        ([], b) <- flattenExpr binds (last args)
+        res <- mkEqComparisons a b
+        return ([], res)
+      else
+        flattenApplicationExpr binds (CoreUtils.exprType app) f args
   where
+    mkEqComparisons :: SignalMap -> SignalMap -> FlattenState SignalMap
+    mkEqComparisons a b = do
+      let zipped = zipValueMaps a b
+      Traversable.mapM mkEqComparison zipped
+
+    mkEqComparison :: (SignalId, SignalId) -> FlattenState SignalId
+    mkEqComparison (a, b) = do
+      -- Generate a signal to hold our result
+      res <- genSignalId SigInternal TysWiredIn.boolTy
+      -- Add a name hint to the signal
+      addNameHint ("s" ++ show a ++ "_eq_s" ++ show b) res
+      addDef (UncondDef (Right $ Eq a b) res)
+      return res
+
     flattenBuildTupleExpr binds args = do
       -- Flatten each of our args
       flat_args <- (State.mapM (flattenExpr binds) args)
@@ -182,6 +233,9 @@ flattenExpr binds app@(App _ _) = do
       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,
@@ -204,43 +258,47 @@ flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
   if not (null b_args)
     then
       error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
-    else
-      let binds' = (b, Left b_res) : binds in
+    else do
+      let binds' = (b, Left b_res) : binds
+      -- Add name hints to the generated signals
+      let binder_name = Name.getOccString b
+      Traversable.mapM (addNameHint binder_name) b_res
       flattenExpr binds' expr
 
 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
 
-flattenExpr binds expr@(Case (Var v) b _ alts) =
+flattenExpr binds expr@(Case scrut b _ alts) = do
+  -- TODO: Special casing for higher order functions
+  -- Flatten the scrutinee
+  (_, res) <- flattenExpr binds scrut
   case alts of
-    [alt] -> flattenSingleAltCaseExpr binds var b alt
-    otherwise -> flattenMultipleAltCaseExpr binds var b alts
+    -- TODO include b in the binds list
+    [alt] -> flattenSingleAltCaseExpr binds res b alt
+    -- Reverse the alternatives, so the __DEFAULT alternative ends up last
+    otherwise -> flattenMultipleAltCaseExpr binds res b (reverse alts)
   where
-    var = Maybe.fromMaybe 
-      (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
-      (lookup v binds)
-
     flattenSingleAltCaseExpr ::
       BindMap
                                 -- A list of bindings in effect
-      -> BindValue              -- The scrutinee
+      -> SignalMap              -- The scrutinee
       -> CoreBndr               -- The binder to bind the scrutinee to
       -> CoreAlt                -- The single alternative
       -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
 
-    flattenSingleAltCaseExpr binds var b alt@(DataAlt datacon, bind_vars, expr) =
+    flattenSingleAltCaseExpr binds scrut b alt@(DataAlt datacon, bind_vars, expr) =
       if DataCon.isTupleCon datacon
-        then
-          let
-            -- Unpack the scrutinee (which must be a variable bound to a tuple) in
-            -- the existing bindings list and get the portname map for each of
-            -- it's elements.
-            Left (Tuple tuple_sigs) = var
-            -- TODO include b in the binds list
-            -- Merge our existing binds with the new binds.
-            binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds 
-          in
-            -- Expand the expression with the new binds list
-            flattenExpr binds' expr
+        then do
+          -- Unpack the scrutinee (which must be a variable bound to a tuple) in
+          -- the existing bindings list and get the portname map for each of
+          -- it's elements.
+          let Tuple tuple_sigs = scrut
+          -- Add name hints to the returned signals
+          let binder_name = Name.getOccString b
+          Monad.zipWithM (\name  sigs -> Traversable.mapM (addNameHint $ Name.getOccString name) sigs) bind_vars tuple_sigs
+          -- Merge our existing binds with the new binds.
+          let binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds 
+          -- Expand the expression with the new binds list
+          flattenExpr binds' expr
         else
           if null bind_vars
             then
@@ -249,41 +307,44 @@ flattenExpr binds expr@(Case (Var v) b _ alts) =
               flattenExpr binds expr
             else
               error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
+
+    flattenSingleAltCaseExpr binds _ _ alt@(DEFAULT, [], expr) =
+      flattenExpr binds expr
+      
     flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 
     flattenMultipleAltCaseExpr ::
       BindMap
                                 -- A list of bindings in effect
-      -> BindValue              -- The scrutinee
+      -> SignalMap              -- The scrutinee
       -> CoreBndr               -- The binder to bind the scrutinee to
       -> [CoreAlt]              -- The alternatives
       -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
 
-    flattenMultipleAltCaseExpr binds var b (a:a':alts) = do
-      (args, res) <- flattenSingleAltCaseExpr binds var b a
-      (args', res') <- flattenMultipleAltCaseExpr binds var b (a':alts)
+    flattenMultipleAltCaseExpr binds scrut b (a:a':alts) = do
+      (args, res) <- flattenSingleAltCaseExpr binds scrut b a
+      (args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts)
       case a of
         (DataAlt datacon, bind_vars, expr) -> do
-          let tycon = DataCon.dataConTyCon datacon
-          let tyname = TyCon.tyConName tycon
-          case Name.getOccString tyname of
-            -- TODO: Do something more robust than string matching
-            "Bit"      -> 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 Left (Single sig) = var
-              let dcname = DataCon.dataConName datacon
-              let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+              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.
-              our_args <- zipWithM (mkConditionals boolsigid) args args'
+              -- 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 $ "Type " ++ (Name.getOccString tyname) ++ " not supported in multiple alternative case expressions."
         otherwise ->
           error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
       where
@@ -302,13 +363,44 @@ flattenExpr binds expr@(Case (Var v) b _ alts) =
           addDef (CondDef boolsigid true false res)
           return res
 
-    flattenMultipleAltCaseExpr binds var b (a:alts) =
-      flattenSingleAltCaseExpr binds var b a
+    flattenMultipleAltCaseExpr binds scrut b (a:alts) =
+      flattenSingleAltCaseExpr binds scrut b a
 
+flattenExpr _ expr = do
+  error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
 
-      
-flattenExpr _ _ = do
-  return ([], Tuple [])
+-- | 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
+
+-- | Translates a dataconstructor without arguments to the corresponding
+--   literal.
+dataConToLiteral :: DataCon.DataCon -> FlattenState String
+dataConToLiteral datacon = do
+  let tycon = DataCon.dataConTyCon datacon
+  let tyname = TyCon.tyConName tycon
+  case Name.getOccString tyname of
+    -- 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" -> "'-'"
+      return lit
+    "Bool" -> do
+      let dcname = DataCon.dataConName datacon
+      let lit = case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+      return lit
+    otherwise ->
+      error $ "Literals of type " ++ (Name.getOccString tyname) ++ " not supported."
 
 appToHsFunction ::
   Type.Type       -- ^ The return type