X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=4bb6e71b268fd140c7f60df47754f12c9dffa6c8;hb=53b8d7183c05b1c1248875bf3a9394a0a7af5518;hp=da665cf3fdb1f768235d394efd285f1302bb1f8a;hpb=9b7d00ad53acfc821840051ef693d87470b4462b;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Flatten.hs b/Flatten.hs index da665cf..4bb6e71 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) @@ -154,11 +157,18 @@ flattenExpr binds var@(Var id) = 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) + if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon) + then do + -- Empty tuple construction + return ([], Tuple []) + else do + lit <- dataConToLiteral datacon + let ty = CoreUtils.exprType var + 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 +194,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 +215,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 +238,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 +263,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) @@ -272,17 +292,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 - -- 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 @@ -310,23 +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 - 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) + 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 @@ -351,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 @@ -375,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 @@ -419,28 +423,4 @@ stateList :: stateList uses signals = Maybe.catMaybes $ Foldable.toList $ zipValueMapsWith filterState signals uses --- | Returns pairs of signals that should be mapped to state in this function. -getOwnStates :: - HsFunction -- | The function to look at - -> FlatFunction -- | The function to look at - -> [(StateId, SignalInfo, SignalInfo)] - -- | The state signals. The first is the state number, the second the - -- signal to assign the current state to, the last is the signal - -- that holds the new state. - -getOwnStates hsfunc flatfunc = - [(old_num, old_info, new_info) - | (old_num, old_info) <- args_states - , (new_num, new_info) <- res_states - , old_num == new_num] - where - sigs = flat_sigs flatfunc - -- Translate args and res to lists of (statenum, sigid) - args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc) - res = stateList (hsFuncRes hsfunc) (flat_res flatfunc) - -- Replace the second tuple element with the corresponding SignalInfo - args_states = map (Arrow.second $ signalInfo sigs) args - res_states = map (Arrow.second $ signalInfo sigs) res - - -- vim: set ts=8 sw=2 sts=2 expandtab: