From 76349636abcb764e8ed3b9ae548730ad2d85abb2 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 23 Sep 2010 10:59:01 +0000 Subject: [PATCH] Remove use of lambda with a refutable pattern --- compiler/ghci/ByteCodeGen.lhs | 50 ++++++++++++------------ compiler/ghci/RtClosureInspect.hs | 5 ++- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 18 ++++----- compiler/rename/RnExpr.lhs | 3 +- compiler/rename/RnPat.lhs | 2 +- compiler/rename/RnSource.lhs | 3 +- 6 files changed, 41 insertions(+), 40 deletions(-) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 9330c71..7d6bc23 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1308,7 +1308,7 @@ mkMultiBranch maybe_ncons raw_ways = return (snd val) | otherwise = do label_neq <- getLabelBc - return (mkTestEQ (fst val) label_neq + return (testEQ (fst val) label_neq `consOL` (snd val `appOL` unitOL (LABEL label_neq) `appOL` the_default)) @@ -1322,7 +1322,7 @@ mkMultiBranch maybe_ncons raw_ways label_geq <- getLabelBc code_lo <- mkTree vals_lo range_lo (dec v_mid) code_hi <- mkTree vals_hi v_mid range_hi - return (mkTestLT v_mid label_geq + return (testLT v_mid label_geq `consOL` (code_lo `appOL` unitOL (LABEL label_geq) `appOL` code_hi)) @@ -1332,34 +1332,32 @@ mkMultiBranch maybe_ncons raw_ways [(_, def)] -> def _ -> panic "mkMultiBranch/the_default" + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + -- None of these will be needed if there are no non-default alts - (mkTestLT, mkTestEQ, init_lo, init_hi) + (init_lo, init_hi) | null notd_ways = panic "mkMultiBranch: awesome foursome" | otherwise - = case fst (head notd_ways) of { - DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label, - \(DiscrI i) fail_label -> TESTEQ_I i fail_label, - DiscrI minBound, - DiscrI maxBound ); - DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label, - \(DiscrW i) fail_label -> TESTEQ_W i fail_label, - DiscrW minBound, - DiscrW maxBound ); - DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label, - \(DiscrF f) fail_label -> TESTEQ_F f fail_label, - DiscrF minF, - DiscrF maxF ); - DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label, - \(DiscrD d) fail_label -> TESTEQ_D d fail_label, - DiscrD minD, - DiscrD maxD ); - DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label, - \(DiscrP i) fail_label -> TESTEQ_P i fail_label, - DiscrP algMinBound, - DiscrP algMaxBound ); - NoDiscr -> panic "mkMultiBranch NoDiscr" - } + = case fst (head notd_ways) of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" (algMinBound, algMaxBound) = case maybe_ncons of diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index fa167e3..ef25ad5 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -426,7 +426,7 @@ cPprTermBase y = . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - (\ p Term{subTerms=[h,t]} -> doList p h t) + (\ p t -> doList p t) , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a) , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a) , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a) @@ -452,7 +452,7 @@ cPprTermBase y = coerceShow f _p = return . text . show . f . unsafeCoerce# . val --Note pprinting of list terms is not lazy - doList p h t = do + doList p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t isConsLast = not(termType(last elems) `coreEqType` termType h) print_elems <- mapM (y cons_prec) elems @@ -468,6 +468,7 @@ cPprTermBase y = getListTerms Term{subTerms=[]} = [] getListTerms t@Suspension{} = [t] getListTerms t = pprPanic "getListTerms" (ppr t) + doList _ _ = panic "doList" repPrim :: TyCon -> [Word] -> String diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 9799587..152d70b 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -79,11 +79,8 @@ slurpSpillCostInfo cmm -- the info table from the CmmProc countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ (Just blockLive) <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId - - , rsLiveEntry_virt <- mapUniqSet (\(RegVirtual vr) -> vr) - $ filterUniqSet isVirtualReg rsLiveEntry - + , Just rsLiveEntry <- lookupBlockEnv blockLive blockId + , rsLiveEntry_virt <- takeVirtuals rsLiveEntry = countLIs rsLiveEntry_virt instrs | otherwise @@ -112,10 +109,6 @@ slurpSpillCostInfo cmm mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written -- compute liveness for entry to next instruction. - let takeVirtuals set - = mapUniqSet (\(RegVirtual vr) -> vr) - $ filterUniqSet isVirtualReg set - let liveDieRead_virt = takeVirtuals (liveDieRead live) let liveDieWrite_virt = takeVirtuals (liveDieWrite live) let liveBorn_virt = takeVirtuals (liveBorn live) @@ -134,6 +127,13 @@ slurpSpillCostInfo cmm incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1) +takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg +takeVirtuals set = mapUniqSet get_virtual + $ filterUniqSet isVirtualReg set + where + get_virtual (RegVirtual vr) = vr + get_virtual _ = panic "getVirt" + -- | Choose a node to spill from this graph chooseSpill diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index de7760e..5598cc0 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -320,7 +320,8 @@ rnExpr (HsArrApp arrow arg _ ho rtl) -- infix form rnExpr (HsArrForm op (Just _) [arg1, arg2]) = escapeArrowScope (rnLExpr op) - `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> + `thenM` \ (op',fv_op) -> + let L _ (HsVar op_name) = op' in rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index d8bcb22..76be451 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -245,7 +245,7 @@ rnPat :: HsMatchContext Name -- for error messages -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\[pat'] -> thing_inside pat') + = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') applyNameMaker :: NameMaker -> Located RdrName -> RnM Name applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 91bc78f..07a596a 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -309,7 +309,8 @@ rnSrcWarnDecls _bound_names [] rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) + ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } -- 1.7.10.4