X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=blobdiff_plain;f=Flatten.hs;h=4bb6e71b268fd140c7f60df47754f12c9dffa6c8;hp=325f742bec2970155ad53093a04354324c7a62a4;hb=2ee391fd9b32f39872abfcf339e949f5139c6cbd;hpb=d5cfe79d359fd4d7177a6cc7232ccb294ce039f8 diff --git a/Flatten.hs b/Flatten.hs index 325f742..4bb6e71 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -331,25 +331,20 @@ 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 - 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) + 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 @@ -374,20 +369,6 @@ 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 @@ -398,7 +379,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'"; "DontCare" -> "'-'" + let lit = case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" return lit "Bool" -> do let dcname = DataCon.dataConName datacon