Support multiple alternative case expressions.

Currently, only Bit expressions can be scrutinized.

This also enhances the SigDefs to support expressions (only comparison
with a literal currently) in unconditional definitions.

diff --git a/Flatten.hs b/Flatten.hs
index ba49d0b8a22a5f7440d1b371a397007ad77e9786..5ffd16263ffe395ca3adebfff4abc72eb7f9e493 100644 (file)
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -7,7 +7,9 @@ import qualified Name
 import qualified Maybe
 import qualified Control.Arrow as Arrow
 import qualified DataCon
+import qualified TyCon
 import qualified CoreUtils
+import qualified TysWiredIn
 import qualified Data.Traversable as Traversable
 import qualified Data.Foldable as Foldable
 import Control.Applicative
@@ -104,18 +106,24 @@ hsUseToSigUse f (id, use) = do
   setSignalInfo id' (info { sigUse = f use})
   return id'
 
--- | Duplicate the given signal, assigning its value to the new signal.
---   Returns the new signal id.
-duplicateSignal :: SignalId -> FlattenState SignalId
-duplicateSignal id = do
+-- | Creates a new internal signal with the same type as the given signal
+copySignal :: SignalId -> FlattenState SignalId
+copySignal id = do
   -- Find the type of the original signal
   info <- getSignalInfo id
   let ty = sigTy info
   -- Generate a new signal (which is SigInternal for now, that will be
   -- sorted out later on).
-  id' <- genSignalId SigInternal ty
+  genSignalId SigInternal ty
+
+-- | Duplicate the given signal, assigning its value to the new signal.
+--   Returns the new signal id.
+duplicateSignal :: SignalId -> FlattenState SignalId
+duplicateSignal id = do
+  -- Create a new signal
+  id' <- copySignal id
   -- Assign the old signal to the new signal
-  addDef $ UncondDef id id'
+  addDef $ UncondDef (Left id) id'
   -- Replace the signal with the new signal
   return id'
         
@@ -204,37 +212,99 @@ flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not sup
 
 flattenExpr binds expr@(Case (Var v) b _ alts) =
   case alts of
-    [alt] -> flattenSingleAltCaseExpr binds v b alt
-    otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
+    [alt] -> flattenSingleAltCaseExpr binds var b alt
+    otherwise -> flattenMultipleAltCaseExpr binds var 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
-      -> Var.Var                -- The scrutinee
+      -> BindValue              -- The scrutinee
       -> CoreBndr               -- The binder to bind the scrutinee to
       -> CoreAlt                -- The single alternative
-      -> FlattenState ( [SignalMap], SignalMap)
-                                           -- See expandExpr
-    flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
-      if not (DataCon.isTupleCon datacon) 
+      -> FlattenState ( [SignalMap], SignalMap) -- See expandExpr
+
+    flattenSingleAltCaseExpr binds var b alt@(DataAlt datacon, bind_vars, expr) =
+      if DataCon.isTupleCon datacon
         then
-          error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
-        else
           let
-            -- Lookup the scrutinee (which must be a variable bound to a tuple) in
+            -- 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) = Maybe.fromMaybe 
-              (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
-              (lookup v binds)
+            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
+        else
+          if null bind_vars
+            then
+              -- DataAlts without arguments don't need processing
+              -- (flattenMultipleAltCaseExpr will have done this already).
+              flattenExpr binds expr
+            else
+              error $ "Dataconstructors other than tuple constructors cannot have binder arguments in case pattern of alternative: " ++ (showSDoc $ ppr alt)
     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
+      -> 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)
+      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."
+        otherwise ->
+          error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a)
+      where
+        -- Select either the first or second signal map depending on the value
+        -- of the first argument (True == first map, False == second map)
+        mkConditionals :: SignalId -> SignalMap -> SignalMap -> FlattenState SignalMap
+        mkConditionals boolsigid true false = do
+          let zipped = zipValueMaps true false
+          Traversable.mapM (mkConditional boolsigid) zipped
+
+        mkConditional :: SignalId -> (SignalId, SignalId) -> FlattenState SignalId
+        mkConditional boolsigid (true, false) = do
+          -- Create a new signal (true and false should be identically typed,
+          -- so it doesn't matter which one we copy).
+          res <- copySignal true
+          addDef (CondDef boolsigid true false res)
+          return res
+
+    flattenMultipleAltCaseExpr binds var b (a:alts) =
+      flattenSingleAltCaseExpr binds var b a
+
 
       
 flattenExpr _ _ = do

diff --git a/FlattenTypes.hs b/FlattenTypes.hs
index 8dbdc3b6ab2b9b1a676cd554ba72a78d96e52b38..c7e0c1e79e6eca5c771c455052b2860b467ca870 100644 (file)
--- a/FlattenTypes.hs
+++ b/FlattenTypes.hs
@@ -92,10 +92,15 @@ data SigDef =
   }
   -- | Unconditional signal definition
   | UncondDef {
-    defSrc :: SignalId,
+    defSrc :: Either SignalId SignalExpr,
     defDst :: SignalId
   } deriving (Show, Eq)
 
+-- | An expression on signals
+data SignalExpr = 
+  EqLit SignalId String -- ^ Is the given signal equal to the given (VHDL) literal
+  deriving (Show, Eq)
+
 -- Returns the function used by the given SigDef, if any
 usedHsFunc :: SigDef -> Maybe HsFunction
 usedHsFunc (FApp hsfunc _ _) = Just hsfunc
@@ -150,6 +155,10 @@ signalInfo sigs id = Maybe.fromJust $ lookup id sigs
 -- | A list of binds in effect at a particular point of evaluation
 type BindMap = [(
   CoreBndr,            -- ^ The bind name
+  BindValue            -- ^ The value bound to it
+  )]
+
+type BindValue =
   Either               -- ^ The bind value which is either
     (SignalMap)
                        -- ^ a signal
@@ -157,7 +166,6 @@ type BindMap = [(
       HsValueUse,      -- ^ or a HighOrder function
       [SignalId]       -- ^ With these signals already applied to it
     )
-  )]
 
 -- | The state during the flattening of a single function
 type FlattenState = State.State ([SigDef], [(SignalId, SignalInfo)], SignalId)

diff --git a/Pretty.hs b/Pretty.hs
index 6d495694f8a7fc4dab1fbe14b9378d550f67a8f7..6608f809088919db992ff7d5a57d62cb2ba623a4 100644 (file)
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -51,8 +51,17 @@ instance Pretty FlatFunction where
 instance Pretty SigDef where
   pPrint (FApp func args res) =
     pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
-  pPrint (CondDef _ _ _ _) = text "TODO"
-  pPrint (UncondDef src dst) = text "TODO"
+  pPrint (CondDef cond true false res) = 
+    pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
+  pPrint (UncondDef src dst) =
+    ppsrc src <> text " -> " <> pPrint dst
+    where
+      ppsrc (Left id) = pPrint id
+      ppsrc (Right expr) = pPrint expr
+
+instance Pretty SignalExpr where
+  pPrint (EqLit id lit) =
+    parens $ pPrint id <> text " = " <> text lit
 
 instance Pretty SignalInfo where
   pPrint (SignalInfo name use ty) =

diff --git a/Translator.hs b/Translator.hs
index cf2fb966876c5ffd612d00360dfe772a4adf2110..98380606884c24ba953a07216d1bb788d1747d22 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -43,9 +43,9 @@ import qualified VHDL
 
 main = do
   -- Load the module
-  core <- loadModule "Adders.hs"
+  core <- loadModule "Alu.hs"
   -- Translate to VHDL
-  vhdl <- moduleToVHDL core ["shifter"]
+  vhdl <- moduleToVHDL core ["salu"]
   -- Write VHDL to file
   writeVHDL vhdl "../vhdl/vhdl/output.vhdl"
 

diff --git a/VHDL.hs b/VHDL.hs
index adf1bf9694faa073f4944dd7c157254c7cb224de..57bebfc12ab0265369ecb7028a6a8740c579d2d6 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -8,6 +8,7 @@ import qualified Maybe
 import qualified Control.Monad as Monad
 
 import qualified Type
+import qualified TysWiredIn
 import qualified Name
 import qualified TyCon
 import Outputable ( showSDoc, ppr )
@@ -193,12 +194,34 @@ mkConcSm sigs (FApp hsfunc args res) = do
   return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 
 mkConcSm sigs (UncondDef src dst) = do
-  let src_name  = AST.NSimple (getSignalId $ signalInfo sigs src)
-  let src_expr  = AST.PrimName src_name
+  let src_expr  = vhdl_expr src
   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
   return $ AST.CSSASm assign
+  where
+    vhdl_expr (Left id) = mkIdExpr sigs id
+    vhdl_expr (Right expr) =
+      case expr of
+        (EqLit id lit) ->
+          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+
+mkConcSm sigs (CondDef cond true false dst) = do
+  let cond_expr  = mkIdExpr sigs cond
+  let true_expr  = mkIdExpr sigs true
+  let false_expr  = mkIdExpr sigs false
+  let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+  let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+  let whenelse = AST.WhenElse true_wform cond_expr
+  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+  let assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+  return $ AST.CSSASm assign
+
+-- | Turn a SignalId into a VHDL Expr
+mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
+mkIdExpr sigs id =
+  let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
+  AST.PrimName src_name
 
 mkAssocElems :: 
   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
@@ -267,6 +290,10 @@ getLibraryUnits (hsfunc, fdata) =
 bit_ty :: AST.TypeMark
 bit_ty = AST.unsafeVHDLBasicId "Bit"
 
+-- | The VHDL Boolean type
+bool_ty :: AST.TypeMark
+bool_ty = AST.unsafeVHDLBasicId "Boolean"
+
 -- | The VHDL std_logic
 std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
@@ -280,14 +307,18 @@ vhdl_ty ty = Maybe.fromMaybe
 -- Translate a Haskell type to a VHDL type
 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
 vhdl_ty_maybe ty =
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) ->
-      let name = TyCon.tyConName tycon in
-        -- TODO: Do something more robust than string matching
-        case Name.getOccString name of
-          "Bit"      -> Just bit_ty
-          otherwise  -> Nothing
-    otherwise -> Nothing
+  if Type.coreEqType ty TysWiredIn.boolTy
+    then
+      Just bool_ty
+    else
+      case Type.splitTyConApp_maybe ty of
+        Just (tycon, args) ->
+          let name = TyCon.tyConName tycon in
+            -- TODO: Do something more robust than string matching
+            case Name.getOccString name of
+              "Bit"      -> Just bit_ty
+              otherwise  -> Nothing
+        otherwise -> Nothing
 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId