Index: simplStg/CaseAltHpc.hs =================================================================== --- simplStg/CaseAltHpc.hs (revision 0) +++ simplStg/CaseAltHpc.hs (revision 141) @@ -0,0 +1,81 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + +module CaseAltHpc where + +#include "HsVersions.h" +#include "../includes/MachRegs.h" + +import StgSyn +import Module +import StaticFlags +import Outputable + +import Control.Monad +import Control.Applicative +import State + +instance Functor (State s) where + fmap = liftM + +instance Applicative (State s) where + pure = return + (<*>) = ap + +class StgWalk a where + stgWalk :: a -> State (Module, Int) a + +instance StgWalk (GenStgBinding bndr occ) where + stgWalk binding + = case binding of + StgNonRec bndr rhs -> StgNonRec bndr <$> stgWalk rhs + StgRec pairs -> do + rhss' <- mapM stgWalk rhss + return . StgRec $ zip bndrs rhss' + where + (bndrs, rhss) = unzip pairs + +instance StgWalk (GenStgRhs bndr occ) where + stgWalk (StgRhsClosure ccs bndrInfo occs uf srt bndrs expr) + = StgRhsClosure ccs bndrInfo occs uf srt bndrs <$> stgWalk expr + stgWalk rhs@StgRhsCon{} + = return rhs + +instance StgWalk (GenStgExpr bndr occ) where + stgWalk expr + = case expr of + StgApp{} -> return expr + StgLit{} -> return expr + StgConApp{} -> return expr + StgOpApp{} -> return expr + StgLam ty bndrs expr-> StgLam ty bndrs <$> stgWalk expr + StgCase expr liveVars1 liveVars2 bndr srt altType alts + -> do + expr' <- stgWalk expr + alts' <- mapM stgWalk alts + return $ StgCase expr' liveVars1 liveVars2 bndr srt altType alts' + StgLet rhs expr -> StgLet <$> stgWalk rhs <*> stgWalk expr + StgLetNoEscape liveVars1 liveVars2 rhs expr + -> StgLetNoEscape liveVars1 liveVars2 + <$> stgWalk rhs <*> stgWalk expr + StgSCC cc expr -> StgSCC cc <$> stgWalk expr + StgTick mod tick expr + -> StgTick mod tick <$> stgWalk expr + _ -> panic "stgWalk: unknown case" + +instance StgWalk (GenStgAlt bndr occ) where + stgWalk (altCon, bndrs, useMasks, expr) = do + (mod, tickNr) <- get + + put (mod, tickNr + 1) + + expr' <- stgWalk expr + + unless (opt_CaseAltHpc || opt_CaseUBS) $ do + panic "stgWalk: Why are you calling me?" + + return (altCon, bndrs, useMasks, StgTick mod tickNr expr') Index: simplStg/SimplStg.lhs =================================================================== --- simplStg/SimplStg.lhs (revision 1) +++ simplStg/SimplStg.lhs (working copy) @@ -30,6 +30,9 @@ import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass ) import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) import Outputable +import StaticFlags +import State +import CaseAltHpc \end{code} \begin{code} @@ -37,7 +40,8 @@ -> Module -- module name (profiling only) -> [StgBinding] -- input... -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... - , CollectedCCs) -- cost centre information (declared and used) + , CollectedCCs -- cost centre information (declared and used) + , Int) -- Number of tick boxes stg2stg dflags module_name binds = do { showPass dflags "Stg2Stg" @@ -54,10 +58,19 @@ ; let srt_binds = computeSRTs processed_binds + ; let + (stgBindings, ids) = unzip srt_binds + (stgBindings', (_, n_tickboxes)) + = runState (mapM stgWalk stgBindings) (module_name, 0) + srt_binds' + | opt_CaseAltHpc || opt_CaseUBS + = zip stgBindings' ids + | otherwise = srt_binds + ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" - (pprStgBindingsWithSRTs srt_binds) + (pprStgBindingsWithSRTs srt_binds') - ; return (srt_binds, cost_centres) + ; return (srt_binds', cost_centres, n_tickboxes) } where Index: codeGen/CaseUBS.hs =================================================================== --- codeGen/CaseUBS.hs (revision 0) +++ codeGen/CaseUBS.hs (revision 141) @@ -0,0 +1,142 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details +module CaseUBS where + +#include "HsVersions.h" +#include "../includes/MachRegs.h" + +import StgSyn +import StaticFlags +import Outputable +import Module + +import Data.Maybe +import Data.List +import Data.Array +import Data.Bits +import Control.Monad +import Control.Arrow +import FiniteMap +import System.IO.Unsafe (unsafePerformIO) + +-- import Trace.Hpc.Mix +-- import Trace.Hpc.Util +import Trace.Hpc.Tix + +-- Case ((Un)Balanced) Search Tree +data CaseST + = Test Test Int -- Divide the alternatives into two parts + (Maybe CaseST) + (Maybe CaseST) + deriving (Eq, Show, Read) + +data Test = Ne | Eq | Lt | Gt | Ge | AndShl + deriving (Eq, Show, Read) + +type TickInfo + = Maybe (Module, Int) + +instance Outputable CaseST where + ppr = text . show + +instance Outputable Integer where + ppr = text . show + +-- Data.Function +infixl 0 `on` +on :: (b -> b -> c) -> (a -> b) -> a -> a -> c +(*) `on` f = \x y -> f x * f y + +getInfoFromStgTick :: GenStgExpr bndr occ -> TickInfo +getInfoFromStgTick (StgTick mod nr _) + | opt_CaseUBS = Just (mod, nr) +getInfoFromStgTick _ = Nothing + +loadTix :: FilePath -> IO (FiniteMap String (Array Int Integer)) +loadTix tixPath = do + mbTix <- readTix tixPath + case mbTix of + Nothing -> panic "no such .tix file" + Just (Tix tixMods) -> do + return $ listToFM [ (name, listArray (0, len-1) ticks) + | TixModule name _ len ticks <- tixMods ] + +{-# NOINLINE tickCountMap #-} +tickCountMap :: FiniteMap String (Array Int Integer) +tickCountMap = unsafePerformIO $ loadTix $ fromJust opt_CaseUBSTixPath + +lookupTickCount :: Module -> Int -> Integer +lookupTickCount m i + = let mName = moduleNameString . moduleName $ m + in maybe (pprTrace "Warning: " (text $ "cannot find ticknr" ++ show i ++ " for module " ++ mName) 0) + (\x -> x ! i) + (lookupFM tickCountMap $ mName) + +countTicks :: Maybe (Module, Int) -> Integer +countTicks = maybe 0 (uncurry lookupTickCount) + +optCUBS :: Int -> Int -> Maybe Integer -> [(Int, Integer)] -> Maybe CaseST +optCUBS lo_tag hi_tag mbCount counts + = commonDefaultOptCUBS lo_tag hi_tag mbCount counts + `mplus` (optCUBS' lo_tag hi_tag + $ maybe [] (return . (,) Nothing) mbCount ++ map (first Just) counts) + +optCUBS' :: Int -> Int -> [(Maybe Int, Integer)] -> Maybe CaseST +optCUBS' lo_tag hi_tag counts + | length counts <= 2 + = Nothing + | opt_CaseUBSTriple && hi_tag - lo_tag == 2 && let xs = map snd counts in minimum xs /= maximum xs + = Just $ testEq (fst $ maximumBy (compare `on` snd) [ (tag, count) | (Just tag, count) <- counts ]) Nothing Nothing + | not opt_CaseUBSNoHalf + = case huge of + [(Just tag, _)] + -> Just (testEq tag Nothing (optCUBS' lo_tag hi_tag smallers)) + _ -> Nothing + | otherwise + = Nothing + where + (huge, smallers) = partition ((> total) . (2*) . snd) counts + total = sum (map snd counts) + testEq tag + | opt_CaseUBSNotEqual = flip (Test Ne tag) + | otherwise = Test Eq tag + +groupBy' eq [] = [] +groupBy' eq (x:xs) = rec [x] xs + where + rec xs [] = [reverse xs] + rec xs@(x:_) (y:ys) + | eq x y = rec (y:xs) ys + | otherwise = reverse xs : rec [y] ys + +commonDefaultOptCUBS :: Int -> Int -> Maybe Integer -> [(Int, Integer)] -> Maybe CaseST +commonDefaultOptCUBS lo_tag hi_tag mbDefCount counts + | opt_CaseUBSCommonDefault + && hi_tag < bitSize (undefined :: Int) + && n_counts > 2 + && defaultIsCommon + && sparse + && rangeCost > 2 + = Just $ Test AndShl (foldl' (\mask tag -> mask .|. (1 `shiftL` tag)) 0 tags) Nothing Nothing + | otherwise + = Nothing + where + n_counts = length counts + rangeCost = 2 * length ranges - loRange - hiRange + tags = map fst counts + ranges = groupBy' (\x y -> y == succ x) $ sort tags + loRange = case ranges of + (t:_):_ + | t == lo_tag -> 1 + | otherwise -> 0 + hiRange = case reverse $ map reverse ranges of + (t:_):_ + | t == hi_tag -> 1 + | otherwise -> 0 + totalTagCount = sum $ map snd counts + defaultIsCommon = fromMaybe 0 mbDefCount > totalTagCount + sparse = (hi_tag - lo_tag + 1) > 2 * length counts Index: codeGen/CgUtils.hs =================================================================== --- codeGen/CgUtils.hs (revision 1) +++ codeGen/CgUtils.hs (working copy) @@ -72,14 +72,18 @@ import ListSetOps import Util import DynFlags +import StaticFlags import FastString import PackageConfig import Outputable +import CaseUBS import Data.Char import Data.Bits import Data.Word import Data.Maybe +import Data.List +import Control.Monad ------------------------------------------------------------------------- -- @@ -170,6 +174,7 @@ ----------------------- cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr +cmmShlWord :: CmmExpr -> CmmExpr -> CmmExpr cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2] @@ -177,7 +182,7 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] ---cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] +cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] --cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] @@ -635,14 +640,14 @@ emitSwitch :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CgStmts)] -- Tagged branches - -> Maybe CgStmts -- Default branch (if any) + -> [(ConTagZ, CgStmts, TickInfo)] -- Tagged branches + -> Maybe (CgStmts, TickInfo) -- Default branch (if any) -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour -- outside this range is undefined -> Code -- ONLY A DEFAULT BRANCH: no case analysis to do -emitSwitch tag_expr [] (Just stmts) _ _ +emitSwitch tag_expr [] (Just (stmts, _)) _ _ = emitCgStmts stmts -- Right, off we go @@ -651,24 +656,90 @@ do { mb_deflt_id <- case mb_deflt of Nothing -> return Nothing - Just stmts -> do id <- forkCgStmts stmts; return (Just id) + Just (stmts, tickInfo) -> Just `liftM` forkCgStmts stmts ; dflags <- getDynFlags ; let via_C | HscC <- hscTarget dflags = True | otherwise = False - ; stmts <- mk_switch tag_expr (sortLe le branches) - mb_deflt_id lo_tag hi_tag via_C - ; emitCgStmts stmts + ; stmts <- mk_switch_ubs tag_expr (sortLe le branches') + mb_deflt_id lo_tag hi_tag via_C caseST + + ; emitCgStmts $ addCommentOrNot stmts } where - (t1,_) `le` (t2,_) = t1 <= t2 + (t1,_) `le` (t2,_) = t1 <= t2 + branches' = [ (tag, stmts) | (tag, stmts, _) <- branches ] + defltCount = (countTicks . snd) `fmap` mb_deflt + tagCounts = [ (tag, countTicks tickInfo) | (tag, _, tickInfo) <- branches ] + caseST + | opt_CaseUBS = optCUBS lo_tag hi_tag defltCount tagCounts + | otherwise = Nothing + commentCons = consCgStmt . CmmComment . mkFastString + addCommentOrNot + | isJust caseST = commentCons ("CaseUBS: tags: " ++ show (lo_tag, hi_tag, defltCount, tagCounts)) + . commentCons ("CaseUBS: caseST: " ++ show caseST) + | otherwise = id +mk_switch_ubs :: CmmExpr -> [(ConTagZ, CgStmts)] + -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool -> Maybe CaseST + -> FCode CgStmts +mk_switch_ubs tag_expr branches mb_deflt lo_tag hi_tag via_C caseST + = case caseST of + Nothing -> mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C + {- + Just test + | pprTrace "mk_switch_ubs: DEBUG: " (text $ show (lo_tag, hi_tag, show test, isJust mb_deflt, map fst branches)) False + -> undefined + -} + Just (Test AndShl mask Nothing no) + | Just deflt <- mb_deflt -> do + (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr + no_stmts <- mk_switch_ubs tag_expr' branches Nothing + real_lo_tag real_hi_tag via_C no + let cond = ((CmmLit (mkIntCLit 1) `cmmShlWord` tag_expr') `cmmAndWord` CmmLit (mkIntCLit mask)) `cmmEqWord` CmmLit (mkIntCLit 0) + return $ assign_tag `consCgStmt` (CmmCondBranch cond deflt `consCgStmt` no_stmts) + where + tags = map fst branches + real_lo_tag = minimum tags + real_hi_tag = maximum tags + + Just (Test cmp tag yes no) + | tag < lo_tag || tag > hi_tag + -> panic $ "mk_switch_ubs: CaseST tag outside of allowed range [" + ++ show lo_tag ++ ".." ++ show hi_tag ++ "]" + | 3 > length branches + if isJust mb_deflt then 1 else 0 + -> panic $ "mk_switch_ubs: Trying to tell me what to do with < 3 alternatives" + | otherwise -> do + (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr + -- To avoid duplication + yes_stmts <- mk_switch_ubs tag_expr' yes_branches mb_deflt + yes_lo_tag yes_hi_tag via_C yes + no_stmts <- mk_switch_ubs tag_expr' no_branches mb_deflt + no_lo_tag no_hi_tag via_C no + yes_id <- forkCgStmts yes_stmts + let branch_stmt = CmmCondBranch cond yes_id + cond = cmmTest tag_expr' (CmmLit (mkIntCLit tag)) + return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` no_stmts)) + where + (cmmTest, (yes_branches, no_branches), yes_lo_tag, yes_hi_tag, no_lo_tag, no_hi_tag) + = case cmp of + Ne -> (cmmNeWord , pBranches (/=tag) , lo_tag, hi_tag , tag , tag ) + Eq -> (cmmEqWord , pBranches (==tag) , tag , tag , lo_tag, hi_tag ) + Lt -> (cmmULtWord , pBranches ( (cmmUGtWord , pBranches (>tag) , tag+1 , hi_tag , lo_tag, tag ) + Ge -> (cmmUGeWord , pBranches (>=tag) , tag , hi_tag , lo_tag, tag - 1) + pBranches p = partition (p . fst) branches + mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool -> FCode CgStmts +-- mk_switch_ubs may split 2 tags+default in mk_switch-with-2-tags and mk_switch-with-only-a-default +mk_switch tag_expr [] (Just deflt) lo_tag hi_tag via_C + = return . oneCgStmt $ CmmBranch deflt + -- SINGLETON TAG RANGE: no case analysis to do mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C | lo_tag == hi_tag Index: codeGen/CodeGen.lhs =================================================================== --- codeGen/CodeGen.lhs (revision 1) +++ codeGen/CodeGen.lhs (working copy) @@ -153,7 +153,7 @@ emitData Data [CmmDataLabel moduleRegdLabel, CmmStaticLit zeroCLit] - ; whenC (opt_Hpc) $ + ; whenC (opt_Hpc || opt_CaseAltHpc) $ hpcTable this_mod hpc_info -- we emit a recursive descent module search for all modules @@ -209,7 +209,7 @@ ; whenC (opt_SccProfilingOn) $ do initCostCentres cost_centre_info - ; whenC (opt_Hpc) $ + ; whenC (opt_Hpc || opt_CaseAltHpc) $ initHpc this_mod hpc_info ; mapCs (registerModuleImport way) Index: codeGen/CgInfoTbls.hs =================================================================== --- codeGen/CgInfoTbls.hs (revision 1) +++ codeGen/CgInfoTbls.hs (working copy) @@ -53,6 +53,7 @@ import Panic import Util import Outputable +import CaseUBS ------------------------------------------------------------------------- -- @@ -272,8 +273,8 @@ emitAlgReturnTarget :: Name -- Just for its unique - -> [(ConTagZ, CgStmts)] -- Tagged branches - -> Maybe CgStmts -- Default branch (if any) + -> [(ConTagZ, CgStmts, TickInfo)] -- Tagged branches + -> Maybe (CgStmts, TickInfo) -- Default branch (if any) -> Int -- family size -> FCode (CLabel, SemiTaggingStuff) @@ -283,7 +284,7 @@ if isSmallFamily fam_sz then do -- yes, node has constr. tag let tag_expr = cmmConstrTag1 (CmmReg nodeReg) - branches' = [(tag+1,branch)|(tag,branch)<-branches] + branches' = [(tag+1,branch, tickInfo)|(tag,branch, tickInfo)<-branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz else do -- no, get tag from info table let -- Note that ptr _always_ has tag 1 Index: codeGen/CgCase.lhs =================================================================== --- codeGen/CgCase.lhs (revision 1) +++ codeGen/CgCase.lhs (working copy) @@ -48,6 +48,7 @@ import TyCon import Util import Outputable +import CaseUBS \end{code} \begin{code} @@ -456,18 +457,18 @@ -> Maybe VirtualSpOffset -> AltType -- ** AlgAlt or PolyAlt only ** -> [StgAlt] -- The alternatives - -> FCode ( [(ConTagZ, CgStmts)], -- The branches - Maybe CgStmts ) -- The default case + -> FCode ( [(ConTagZ, CgStmts, TickInfo)], -- The branches + Maybe (CgStmts, TickInfo) ) -- The default case cgAlgAlts gc_flag cc_slot alt_type alts = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts] let mb_deflt = case alts of -- DEFAULT is always first, if present - ((DEFAULT,blks) : _) -> Just blks - other -> Nothing + ((DEFAULT,blks,tickInfo) : _) -> Just (blks, tickInfo) + other -> Nothing - branches = [(dataConTagZ con, blks) - | (DataAlt con, blks) <- alts] + branches = [(dataConTagZ con, blks, tickInfo) + | (DataAlt con, blks, tickInfo) <- alts] -- in return (branches, mb_deflt) @@ -476,14 +477,14 @@ -> Maybe VirtualSpOffset -- Turgid state -> AltType -- ** AlgAlt or PolyAlt only ** -> StgAlt - -> FCode (AltCon, CgStmts) + -> FCode (AltCon, CgStmts, TickInfo) cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs) = do { abs_c <- getCgStmts $ do { bind_con_args con args ; restoreCurrentCostCentre cc_slot True ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } - ; return (con, abs_c) } + ; return (con, abs_c, getInfoFromStgTick rhs) } where bind_con_args DEFAULT args = nopC bind_con_args (DataAlt dc) args = bindConArgs dc args Index: codeGen/CgExpr.lhs =================================================================== --- codeGen/CgExpr.lhs (revision 1) +++ codeGen/CgExpr.lhs (working copy) @@ -49,6 +49,8 @@ import BasicTypes import Util import Outputable +import StaticFlags +import Control.Monad ( unless ) \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -274,7 +276,10 @@ %******************************************************** \begin{code} -cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr +cgExpr (StgTick m n expr) = do + unless opt_CaseUBS $ do + cgTickBox m n + cgExpr expr \end{code} %******************************************************** @@ -327,9 +332,17 @@ body@(StgCase (StgApp scrutinee [{-no args-}]) _ _ _ srt -- ignore uniq, etc. (AlgAlt tycon) - [(DataAlt con, params, use_mask, - (StgApp selectee [{-no args-}]))]) - | the_fv == scrutinee -- Scrutinee is the only free variable + [(DataAlt con, params, use_mask,rhs)]) + | Just selectee <- test rhs + , let + lf_info = mkSelectorLFInfo bndr offset_into_int + (isUpdatable upd_flag) + (_, params_w_offsets) = layOutDynConstr con (addIdReps params) + -- Just want the layout + maybe_offset = assocMaybe params_w_offsets selectee + Just the_offset = maybe_offset + offset_into_int = the_offset - fixedHdrSize + , the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) @@ -340,13 +353,10 @@ -- will evaluate to. setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where - lf_info = mkSelectorLFInfo bndr offset_into_int - (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr con (addIdReps params) - -- Just want the layout - maybe_offset = assocMaybe params_w_offsets selectee - Just the_offset = maybe_offset - offset_into_int = the_offset - fixedHdrSize + test rhs = case rhs of + StgApp selectee []-> Just selectee + StgTick _ _ expr -> test expr + _ -> Nothing \end{code} Ap thunks Index: main/HscMain.lhs =================================================================== --- main/HscMain.lhs (revision 1) +++ main/HscMain.lhs (working copy) @@ -92,6 +92,7 @@ import NameEnv ( emptyNameEnv ) import DynFlags +import StaticFlags import ErrUtils import UniqSupply ( mkSplitUniqSupply ) @@ -657,14 +658,17 @@ prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm dflags core_binds data_tycons ; ----------------- Convert to STG ------------------ - (stg_binds, cost_centre_info) + (stg_binds, cost_centre_info, n_tickboxes) <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ + let hpc_info' + | opt_CaseAltHpc = HpcInfo n_tickboxes (-1) + | otherwise = hpc_info abstractC <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons dir_imps cost_centre_info - stg_binds hpc_info + stg_binds hpc_info' ------------------ Convert to CPS -------------------- --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm continuationC <- cmmToRawCmm abstractC @@ -772,10 +776,10 @@ stg_binds <- {-# SCC "Core2Stg" #-} coreToStg (thisPackage dflags) prepd_binds - (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} + (stg_binds2, cost_centre_info, n_tickboxes) <- {-# SCC "Stg2Stg" #-} stg2stg dflags this_mod stg_binds - return (stg_binds2, cost_centre_info) + return (stg_binds2, cost_centre_info, n_tickboxes) \end{code} Index: main/StaticFlags.hs =================================================================== --- main/StaticFlags.hs (revision 1) +++ main/StaticFlags.hs (working copy) @@ -38,6 +38,16 @@ -- Hpc opts opt_Hpc, + -- Case UBS opts + opt_CaseAltHpc, + opt_CaseUBS, + opt_CaseUBSTixPath, + opt_CaseUBSTriple, + opt_CaseUBSNoHalf, + opt_CaseUBSCommonDefault, + opt_CaseUBSNotEqual, + opt_CaseJumpTableThreshold, + -- language opts opt_DictsStrict, opt_IrrefutableTuples, @@ -94,6 +104,7 @@ import Control.Monad ( when ) import Data.Char ( isDigit ) import Data.List +import Data.Maybe ( isJust ) ----------------------------------------------------------------------------- -- Static flags @@ -296,6 +307,21 @@ -- Hpc opts opt_Hpc = lookUp FSLIT("-fhpc") +-- Case UBS opts +opt_CaseAltHpc + | opt_Hpc = panic "Cannot use both -fhpc and -fcase-alt-hpc" + | otherwise = lookUp FSLIT("-fcase-alt-hpc") + +opt_CaseUBS = isJust opt_CaseUBSTixPath +opt_CaseUBSTixPath = lookup_str "-fcase-ubs-tix" +opt_CaseUBSTriple = lookUp FSLIT("-fcase-ubs-triple") +opt_CaseUBSNoHalf = lookUp FSLIT("-fcase-ubs-no-half") +opt_CaseUBSCommonDefault + = lookUp FSLIT("-fcase-ubs-common-default") +opt_CaseUBSNotEqual = lookUp FSLIT("-fcase-ubs-not-equal") +opt_CaseJumpTableThreshold + = lookup_def_int "-fcase-jump-table-threshold" 4 + -- language opts opt_DictsStrict = lookUp FSLIT("-fdicts-strict") opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") @@ -383,9 +409,16 @@ "fcpr-off", "ferror-spans", "fPIC", - "fhpc" + "fhpc", + "fcase-alt-hpc", + "fcase-ubs-triple", + "fcase-ubs-no-half", + "fcase-ubs-common-default", + "fcase-ubs-not-equal" ] || any (`isPrefixOf` f) [ + "fcase-ubs-tix", + "fcase-jump-table-threshold", "fliberate-case-threshold", "fmax-worker-args", "fhistory-size", Index: cmm/CmmParse.hs =================================================================== --- cmm/CmmParse.hs (revision 141) +++ cmm/CmmParse.hs (working copy) @@ -63,12 +63,7 @@ -- parser produced by Happy Version 1.16 -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = GHC.Exts.Any -#else -type HappyAny = forall a . a -#endif +newtype HappyAbsSyn = HappyAbsSyn (() -> ()) happyIn4 :: (ExtCode) -> (HappyAbsSyn ) happyIn4 x = unsafeCoerce# x {-# INLINE happyIn4 #-} @@ -358,7 +353,6 @@ happyOutTok x = unsafeCoerce# x {-# INLINE happyOutTok #-} - happyActOffsets :: HappyAddr happyActOffsets = HappyA# "\x3f\x01\x00\x00\x8e\x03\x3f\x01\x00\x00\x00\x00\xc9\x03\x00\x00\x90\x03\x00\x00\xc7\x03\xc4\x03\xb0\x03\xaf\x03\xae\x03\x9b\x03\x75\x03\x61\x03\x64\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x03\x9d\x03\x4f\x03\x63\x03\x35\x01\x8b\x03\x47\x03\x78\x03\x5a\x03\x3b\x03\x3a\x03\x2c\x03\x29\x03\x28\x03\x22\x03\x4a\x03\x07\x00\x00\x00\x0f\x03\x00\x00\x0c\x03\x00\x00\x45\x03\x44\x03\x43\x03\x3d\x03\x39\x03\x2b\x03\x00\x00\xee\xff\x06\x03\x00\x00\x36\x03\x00\x00\x1d\x03\xf8\x02\x9d\x03\x02\x03\x2d\x03\x00\x00\x26\x03\x5e\x00\xe6\x02\x00\x00\x35\x01\x00\x00\x00\x00\x1e\x03\xee\xff\xff\xff\x1c\x03\x0d\x03\xda\x02\x01\x03\xfe\x02\xd6\x02\xd2\x02\xcc\x02\xc8\x02\xc4\x02\xbc\x02\x00\x00\xf4\x02\x19\x00\xe2\x02\xdb\x02\x0b\x00\xd7\x02\xd4\x02\xcd\x02\x00\x00\x02\x00\xe7\x02\x9d\x02\x9e\x02\x9c\x01\xd1\x02\x00\x00\xd0\x02\x00\x00\x5e\x00\x5e\x00\x92\x02\x5e\x00\x00\x00\x00\x00\x00\x00\xb5\x02\xb5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x02\x19\x00\xc9\x02\x19\x00\x19\x00\xe5\xff\xbe\x02\x0d\x00\x00\x00\x97\x00\x84\x02\x53\x00\x5e\x00\xb9\x02\xba\x02\x00\x00\x0e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x00\x00\x9d\x03\x00\x00\x5a\x00\xb2\x02\x00\x00\x47\x02\x5e\x00\x73\x02\x00\x00\xab\x02\x93\x02\x00\x00\x5c\x02\x8f\x02\x74\x02\x6a\x02\x63\x02\x00\x00\x35\x01\x62\x02\x8e\x02\x5e\x00\x90\x02\x00\x00\x76\x03\x8a\x02\x71\x02\x7e\x02\x6f\x02\x6c\x02\x5b\x02\x68\x02\x67\x02\x57\x02\x5e\x02\x54\x02\xe4\x01\x00\x00\x5e\x00\x00\x00\x9e\x03\x9e\x03\x9e\x03\x9e\x03\xc5\x01\xc5\x01\x9e\x03\x9e\x03\xb2\x03\xb9\x03\x43\x01\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x62\x03\x55\x02\x00\x00\x00\x00\x5e\x00\x5e\x00\x10\x02\x50\x02\x5e\x00\x16\x02\x04\x00\x00\x00\x8a\x03\x53\x00\x53\x00\x4e\x02\x40\x02\x31\x02\x00\x00\x00\x00\x07\x02\x5e\x00\x5e\x00\x05\x02\x2c\x02\x00\x00\x00\x00\x00\x00\xfa\x01\x5e\x00\x88\x01\xca\x01\x00\x00\x97\x00\x2e\x02\x00\x00\x00\x00\xa3\x00\x30\x02\x47\x02\x19\x00\x53\x00\x53\x00\x2d\x02\x95\x00\x26\x02\x00\x00\x17\x02\x00\x00\x14\x02\xb0\x01\x19\x02\x00\x00\x5e\x00\x18\x02\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x01\xde\x01\xdd\x01\x00\x00\xd2\x01\x00\x00\x00\x00\x00\x02\xff\x01\xfe\x01\xf2\x01\x00\x00\x00\x00\x00\x00\x04\x02\xcf\x01\xbc\x01\x5e\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xdc\x01\xf7\x01\x00\x00\x00\x00\x00\x00\xf1\x01\x00\x00\xfd\x01\xe8\x01\x5e\x00\x5e\x00\x5e\x00\xc6\x01\x00\x00\xe7\x01\xac\x01\xb6\x01\xaa\x01\x00\x00\xa2\x01\x9f\x01\x89\x01\x86\x01\xcb\x01\xb2\x01\xb1\x01\xad\x01\xb3\x01\x8b\x01\x00\x00\xae\x01\x9e\x01\x00\x00\x00\x00\x9d\x01\x74\x01\x85\x01\x84\x01\x4b\x01\x4b\x01\x00\x00\x19\x00\x7a\x01\x00\x00\x26\x01\x5d\x01\x00\x00\x34\x01\x2a\x01\x1c\x01\x51\x01\x42\x01\x37\x01\x19\x00\x00\x00\x19\x00\x46\x01\x44\x01\x00\x00\x44\x01\x45\x01\x06\x00\x12\x01\x00\x00\x3d\x01\x38\x01\xf9\x00\xf5\x00\x00\x00\x09\x00\x30\x01\x00\x00\x00\x00\x2e\x01\xf7\x00\x20\x01\x00\x00\x0c\x01\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x11\x01\x00\x00\x00\x00\x00\x00"#