From: Matthijs Kooijman Date: Thu, 19 Feb 2009 10:26:25 +0000 (+0100) Subject: Support multiple alternative case expressions. X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=1e30fe04f4c285970ad2d5e23930dd935b4214fa 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 ba49d0b..5ffd162 100644 --- 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 8dbdc3b..c7e0c1e 100644 --- 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 6d49569..6608f80 100644 --- 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 cf2fb96..9838060 100644 --- 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 adf1bf9..57bebfc 100644 --- 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