Make register_bank work, with a bunch of changes.

Add special casing for the "fst", "snd", "patError" and "==" functions.

Add literal and equality tests to the SignalExpr type.

Allow data constructors to be used in expression, when they have a
corresponding literal in VHDL.

Allow full expressions to be scrutinized instead of just variables.

Perhaps more...

diff --git a/Flatten.hs b/Flatten.hs
index fc60d6ae397dec21840cb21de54e9389fb07ba84..f62046c369c5889e507ab546d979e6e9a7389cc9 100644 (file)
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -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
@@ -141,14 +142,25 @@ flattenExpr binds lam@(Lam b expr) = do
   (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
+      id <- genSignalId SigInternal ty
+      addDef (UncondDef (Right $ Literal lit) id)
+      return ([], Single 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 +174,38 @@ 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
+        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
+      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)
@@ -210,31 +252,30 @@ flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
 
 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
+    [alt] -> flattenSingleAltCaseExpr binds res b alt
+    otherwise -> flattenMultipleAltCaseExpr binds res b 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
+            Tuple tuple_sigs = scrut
             -- TODO include b in the binds list
             -- Merge our existing binds with the new binds.
             binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds 
@@ -254,36 +295,28 @@ flattenExpr binds expr@(Case (Var v) b _ alts) =
     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
-              -- 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'"
-              -- Create a signal that contains a boolean
-              boolsigid <- genSignalId SigInternal TysWiredIn.boolTy
-              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'
-              our_res  <- mkConditionals boolsigid res res'
-              return (our_args, our_res)
-            otherwise ->
-              error $ "Type " ++ (Name.getOccString tyname) ++ " not supported in multiple alternative case expressions."
+          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
+          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'
+          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
@@ -302,13 +335,30 @@ 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
-
-
-      
-flattenExpr _ _ = do
-  return ([], Tuple [])
+    flattenMultipleAltCaseExpr binds scrut b (a:alts) =
+      flattenSingleAltCaseExpr binds scrut b a
+
+flattenExpr _ expr = do
+  error $ "Unsupported expression: " ++ (showSDoc $ ppr expr)
+
+-- | 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'"
+      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

diff --git a/FlattenTypes.hs b/FlattenTypes.hs
index c7e0c1e79e6eca5c771c455052b2860b467ca870..092baff4911fdcb6789399ec613c09293fe30f02 100644 (file)
--- a/FlattenTypes.hs
+++ b/FlattenTypes.hs
@@ -99,6 +99,8 @@ data SigDef =
 -- | An expression on signals
 data SignalExpr = 
   EqLit SignalId String -- ^ Is the given signal equal to the given (VHDL) literal
+  | Literal String -- ^ A literal value
+  | Eq SignalId SignalId -- ^ A comparison between to signals
   deriving (Show, Eq)
 
 -- Returns the function used by the given SigDef, if any

diff --git a/Pretty.hs b/Pretty.hs
index 6608f809088919db992ff7d5a57d62cb2ba623a4..679d7ae4261c1b24ff3f4b61b9f92cab3af2ed8c 100644 (file)
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -36,7 +36,7 @@ instance Pretty x => Pretty (HsValueMap x) where
 
 instance Pretty HsValueUse where
   pPrint Port            = char 'P'
-  pPrint (State n)       = char 'C' <> int n
+  pPrint (State n)       = char 'S' <> int n
   pPrint (HighOrder _ _) = text "Higher Order"
 
 instance Pretty FlatFunction where
@@ -62,6 +62,10 @@ instance Pretty SigDef where
 instance Pretty SignalExpr where
   pPrint (EqLit id lit) =
     parens $ pPrint id <> text " = " <> text lit
+  pPrint (Literal lit) =
+    text lit
+  pPrint (Eq a b) =
+    parens $ pPrint a <> text " = " <> pPrint b
 
 instance Pretty SignalInfo where
   pPrint (SignalInfo name use ty) =

diff --git a/Translator.hs b/Translator.hs
index 75a875bf8426e43f157e0ab6bf07f3435329326d..1a753c2d52b592af9dbc50811bf90b5330f35702 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -42,7 +42,7 @@ import VHDLTypes
 import qualified VHDL
 
 main = do
-  makeVHDL "Alu.hs" "salu"
+  makeVHDL "Alu.hs" "register_bank"
 
 makeVHDL :: String -> String -> IO ()
 makeVHDL filename name = do

diff --git a/VHDL.hs b/VHDL.hs
index 57bebfc12ab0265369ecb7028a6a8740c579d2d6..b85d6ff0be288e7db0ec57ca886fae79cbc6ec09 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -205,6 +205,10 @@ mkConcSm sigs (UncondDef src dst) = do
       case expr of
         (EqLit id lit) ->
           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+        (Literal lit) ->
+          AST.PrimLit lit
+        (Eq a b) ->
+          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 
 mkConcSm sigs (CondDef cond true false dst) = do
   let cond_expr  = mkIdExpr sigs cond