X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=11738c70f5803509056662013ee711b6fec93c54;hb=c0fa1614f8bb0126868658fad79b01df447e113a;hp=f62046c369c5889e507ab546d979e6e9a7389cc9;hpb=14367b6b9fd0770a78e02fad425daa369df4bec6;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index f62046c..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 @@ -138,6 +138,9 @@ 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) @@ -156,9 +159,11 @@ flattenExpr binds var@(Var id) = 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) + 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) @@ -184,6 +189,8 @@ flattenExpr binds app@(App _ _) = do 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) @@ -203,6 +210,8 @@ flattenExpr binds app@(App _ _) = do 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 @@ -224,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, @@ -246,8 +258,11 @@ 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) @@ -257,8 +272,10 @@ flattenExpr binds expr@(Case scrut b _ alts) = do -- Flatten the scrutinee (_, res) <- flattenExpr binds scrut case alts of + -- TODO include b in the binds list [alt] -> flattenSingleAltCaseExpr binds res b alt - otherwise -> flattenMultipleAltCaseExpr binds res b alts + -- Reverse the alternatives, so the __DEFAULT alternative ends up last + otherwise -> flattenMultipleAltCaseExpr binds res b (reverse alts) where flattenSingleAltCaseExpr :: BindMap @@ -270,18 +287,18 @@ flattenExpr binds expr@(Case scrut b _ alts) = do 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. - 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 - 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 @@ -290,6 +307,10 @@ flattenExpr binds expr@(Case scrut b _ alts) = do 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 :: @@ -305,18 +326,25 @@ flattenExpr binds expr@(Case scrut b _ alts) = do (args', res') <- flattenMultipleAltCaseExpr binds scrut b (a':alts) case a of (DataAlt datacon, bind_vars, expr) -> do - 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) + 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 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. + -- 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 $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr a) where @@ -341,6 +369,20 @@ flattenExpr binds expr@(Case scrut b _ alts) = do flattenExpr _ expr = do error $ "Unsupported expression: " ++ (showSDoc $ ppr expr) +-- | 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 @@ -351,7 +393,7 @@ dataConToLiteral datacon = do -- 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'" + let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"; "DontCare" -> "'-'" return lit "Bool" -> do let dcname = DataCon.dataConName datacon