From: Matthijs Kooijman Date: Thu, 19 Feb 2009 12:14:13 +0000 (+0100) Subject: Make register_bank work, with a bunch of changes. X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=14367b6b9fd0770a78e02fad425daa369df4bec6 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 fc60d6a..f62046c 100644 --- 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 c7e0c1e..092baff 100644 --- 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 6608f80..679d7ae 100644 --- 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 75a875b..1a753c2 100644 --- 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 57bebfc..b85d6ff 100644 --- 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