diff options
| author | Ian Lynagh <igloo@earth.li> | 2012-07-19 20:38:05 +0100 |
|---|---|---|
| committer | Ian Lynagh <igloo@earth.li> | 2012-07-19 20:38:05 +0100 |
| commit | 322044b2670fe9dca22122dbf4cc79fa29b4442c (patch) | |
| tree | e3226359676fab1cc0560f6ed827d598fb2ddfc5 | |
| parent | fb0769b62e3ea4392ad970f8913a76187fead79f (diff) | |
| parent | 0f693381e356ec90ee72ab40b21b74cbf4e20eb3 (diff) | |
| download | haskell-322044b2670fe9dca22122dbf4cc79fa29b4442c.tar.gz | |
Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
51 files changed, 1555 insertions, 551 deletions
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index ebe755219b..651cc6f40f 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -13,17 +13,15 @@ -- Todo: remove -fno-warn-warnings-deprecations {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmBuildInfoTables - ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo - , setInfoTableSRT - , TopSRT, emptySRT, srtToData - , bundleCAFs - , cafTransfers ) + ( CAFSet, CAFEnv, cafAnal + , doSRTs, TopSRT, emptySRT, srtToData ) where #include "HsVersions.h" -- These should not be imported here! import StgCmmUtils +import Hoopl import Digraph import qualified Prelude as P @@ -41,13 +39,13 @@ import Name import Outputable import SMRep import UniqSupply - -import Hoopl +import Util import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Control.Monad foldSet :: (a -> b -> b) -> b -> Set a -> b #if __GLASGOW_HASKELL__ < 704 @@ -71,6 +69,44 @@ foldSet = Set.foldr -- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE. -- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures). +{- EXAMPLE + +f = \x. ... g ... + where + g = \y. ... h ... c1 ... + h = \z. ... c2 ... + +c1 & c2 are CAFs + +g and h are local functions, but they have no static closures. When +we generate code for f, we start with a CmmGroup of four CmmDecls: + + [ f_closure, f_entry, g_entry, h_entry ] + +we process each CmmDecl separately in cpsTop, giving us a list of +CmmDecls. e.g. for f_entry, we might end up with + + [ f_entry, f1_ret, f2_proc ] + +where f1_ret is a return point, and f2_proc is a proc-point. We have +a CAFSet for each of these CmmDecls, let's suppose they are + + [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ] + [ g_entry{h_closure, c1_closure} ] + [ h_entry{c2_closure} ] + +Now, note that we cannot use g_closure and h_closure in an SRT, +because there are no static closures corresponding to these functions. +So we have to flatten out the structure, replacing g_closure and +h_closure with their contents: + + [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ] + [ g_entry{c2_closure, c1_closure} ] + [ h_entry{c2_closure} ] + +This is what mkTopCAFInfo is doing. + +-} ----------------------------------------------------------------------- -- Finding the CAFs used by a procedure @@ -147,16 +183,13 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, -- we make sure they're all close enough to the bottom of the table that the -- bitmap will be able to cover all of them. -buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet -> - UniqSM (TopSRT, Maybe CmmDecl, C_SRT) -buildSRTs topSRT topCAFMap cafs = - do let liftCAF lbl z = -- get CAFs for functions without static closures - case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs - Nothing -> Set.insert lbl z +buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) +buildSRTs topSRT cafs = + do let -- For each label referring to a function f without a static closure, -- replace it with the CAFs that are reachable from f. sub_srt topSRT localCafs = - let cafs = Set.elems (foldSet liftCAF Set.empty localCafs) + let cafs = Set.elems localCafs mkSRT topSRT = do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs return (topSRT, localSRTs) @@ -230,15 +263,15 @@ to_SRT top_srt off len bmp -- keep its CAFs live.) -- Any procedure referring to a non-static CAF c must keep live -- any CAF that is reachable from c. -localCAFInfo :: CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet) -localCAFInfo _ (CmmData _ _) = Nothing +localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) +localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of - CmmInfoTable { cit_rep = rep } - | not (isStaticRep rep) - -> Just (toClosureLbl top_l, - expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) - _ -> Nothing + CmmInfoTable { cit_rep = rep } | not (isStaticRep rep) + -> (cafs, Just (toClosureLbl top_l)) + _other -> (cafs, Nothing) + where + cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv -- Once we have the local CAF sets for some (possibly) mutually -- recursive functions, we can create an environment mapping @@ -251,54 +284,77 @@ localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = -- the environment with every reference to f replaced by its set of CAFs. -- To do this replacement efficiently, we gather strongly connected -- components, then we sort the components in topological order. -mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet +mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet mkTopCAFInfo localCAFs = foldl addToTop Map.empty g - where addToTop env (AcyclicSCC (l, cafset)) = + where + addToTop env (AcyclicSCC (l, cafset)) = Map.insert l (flatten env cafset) env addToTop env (CyclicSCC nodes) = let (lbls, cafsets) = unzip nodes cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls - flatten env cafset = foldSet (lookup env) Set.empty cafset - lookup env caf cafset' = - case Map.lookup caf env of Just cafs -> foldSet add cafset' cafs - Nothing -> add caf cafset' - add caf cafset' = Set.insert caf cafset' + g = stronglyConnCompFromEdgedVertices - (map (\n@(l, cafs) -> (n, l, Set.elems cafs)) localCAFs) - --- Bundle the CAFs used at a procpoint. -bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl) -bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) = - (expectJust "bundleCAFs" (mapLookup entry cafEnv), t) -bundleCAFs _ t = (Set.empty, t) - --- Construct the SRTs for the given procedure. -setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) -> - UniqSM (TopSRT, [CmmDecl]) -setInfoTableSRT topCAFMap topSRT (cafs, t) = - setSRT cafs topCAFMap topSRT t - -setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT -> - CmmDecl -> UniqSM (TopSRT, [CmmDecl]) -setSRT cafs topCAFMap topSRT t = - do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs - let t' = updInfo id (const srt) t - case cafTable of - Just tbl -> return (topSRT, [t', tbl]) - Nothing -> return (topSRT, [t']) - -type StackLayout = Liveness - -updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl -updInfo toVars toSrt (CmmProc top_info top_l g) = - CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g -updInfo _ _ t = t - -updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable -updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {}) - = info_tbl { cit_srt = toSrt (cit_srt info_tbl) - , cit_rep = case cit_rep info_tbl of - StackRep ls -> StackRep (toVars ls) - other -> other } -updInfoTbl _ _ t@CmmNonInfoTable = t + [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ] + +flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet +flatten env cafset = foldSet (lookup env) Set.empty cafset + where + lookup env caf cafset' = + case Map.lookup caf env of + Just cafs -> foldSet Set.insert cafset' cafs + Nothing -> Set.insert caf cafset' + +bundle :: Map CLabel CAFSet + -> (CAFEnv, CmmDecl) + -> (CAFSet, Maybe CLabel) + -> (CAFSet, CmmDecl) +bundle flatmap (_, decl) (cafs, Nothing) + = (flatten flatmap cafs, decl) +bundle flatmap (_, decl) (_, Just l) + = (expectJust "bundle" $ Map.lookup l flatmap, decl) + +flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)] +flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs + where + zipped = [(e,d) | (e,ds) <- cpsdecls, d <- ds ] + localCAFs = unzipWith localCAFInfo zipped + flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs + +doSRTs :: TopSRT + -> [(CAFEnv, [CmmDecl])] + -> IO (TopSRT, [CmmDecl]) + +doSRTs topSRT tops + = do + let caf_decls = flattenCAFSets tops + us <- mkSplitUniqSupply 'u' + let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls + return (topSRT', reverse gs' {- Note [reverse gs] -}) + where + setSRT (topSRT, rst) (cafs, decl@(CmmProc{})) = do + (topSRT, cafTable, srt) <- buildSRTs topSRT cafs + let decl' = updInfo (const srt) decl + case cafTable of + Just tbl -> return (topSRT, decl': tbl : rst) + Nothing -> return (topSRT, decl' : rst) + setSRT (topSRT, rst) (_, decl) = + return (topSRT, decl : rst) + +{- Note [reverse gs] + + It is important to keep the code blocks in the same order, + otherwise binary sizes get slightly bigger. I'm not completely + sure why this is, perhaps the assembler generates bigger jump + instructions for forward refs. --SDM +-} + +updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl +updInfo toSrt (CmmProc top_info top_l g) = + CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g +updInfo _ t = t + +updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable +updInfoTbl toSrt info_tbl@(CmmInfoTable {}) + = info_tbl { cit_srt = toSrt (cit_srt info_tbl) } +updInfoTbl _ t@CmmNonInfoTable = t diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 732fb2b849..d45c4d8546 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -3,7 +3,7 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} #endif module CmmLayoutStack ( - cmmLayoutStack, setInfoTableStackMap, cmmSink + cmmLayoutStack, setInfoTableStackMap ) where import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX @@ -34,7 +34,7 @@ import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array import Data.Bits -import Data.List (nub, partition) +import Data.List (nub) import Control.Monad (liftM) #include "HsVersions.h" @@ -111,20 +111,20 @@ cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph cmmLayoutStack procpoints entry_args graph0@(CmmGraph { g_entry = entry }) = do - pprTrace "cmmLayoutStack" (ppr entry_args) $ return () + -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return () (graph, liveness) <- removeDeadAssignments graph0 - pprTrace "liveness" (ppr liveness) $ return () + -- pprTrace "liveness" (ppr liveness) $ return () let blocks = postorderDfs graph - (final_stackmaps, final_high_sp, new_blocks) <- + (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> layout procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks new_blocks' <- mapM lowerSafeForeignCall new_blocks - pprTrace ("Sp HWM") (ppr final_high_sp) $ - return (ofBlockList entry new_blocks', final_stackmaps) + -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return () + return (ofBlockList entry new_blocks', final_stackmaps) @@ -167,7 +167,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks (pprPanic "no stack map for" (ppr entry_lbl)) entry_lbl acc_stackmaps - pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return () + -- pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return () -- (a) Update the stack map to include the effects of -- assignments in this block @@ -188,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks <- handleLastNode procpoints liveness cont_info acc_stackmaps stack1 middle0 last0 - pprTrace "layout(out)" (ppr out) $ return () + -- pprTrace "layout(out)" (ppr out) $ return () -- (d) Manifest Sp: run over the nodes in the block and replace -- CmmStackSlot with CmmLoad from Sp with a concrete offset. @@ -416,8 +416,8 @@ handleLastNode procpoints liveness cont_info stackmaps case mapLookup l stackmaps of Just pp_sm -> (pp_sm, fixupStack stack0 pp_sm) Nothing -> - pprTrace "first visit to proc point" - (ppr l <+> ppr stack1) $ + --pprTrace "first visit to proc point" + -- (ppr l <+> ppr stack1) $ (stack1, assigs) where cont_args = mapFindWithDefault 0 l cont_info @@ -570,7 +570,7 @@ allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O]) allocate ret_off live stackmap@StackMap{ sm_sp = sp0 , sm_regs = regs0 } = - pprTrace "allocate" (ppr live $$ ppr stackmap) $ + -- pprTrace "allocate" (ppr live $$ ppr stackmap) $ -- we only have to save regs that are not already in a slot let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live) @@ -798,7 +798,8 @@ elimStackStores stackmap stackmaps area_off nodes CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) | Just (_,off) <- lookupUFM (sm_regs stackmap) r , area_off area + m == off - -> pprTrace "eliminated a node!" (ppr r) $ go stackmap ns + -> -- pprTrace "eliminated a node!" (ppr r) $ + go stackmap ns _otherwise -> n : go (procMiddle stackmaps n stackmap) ns @@ -978,75 +979,3 @@ insertReloads stackmap = stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)] stackSlotRegs sm = eltsUFM (sm_regs sm) --- ----------------------------------------------------------------------------- - --- If we do this *before* stack layout, we might be able to avoid --- saving some things across calls/procpoints. --- --- *but*, that will invalidate the liveness analysis, and we'll have --- to re-do it. - -cmmSink :: CmmGraph -> UniqSM CmmGraph -cmmSink graph = do - let liveness = cmmLiveness graph - return $ cmmSink' liveness graph - -cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph -cmmSink' liveness graph - = ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph - where - - sink :: BlockEnv [(LocalReg, CmmExpr)] -> [CmmBlock] -> [CmmBlock] - sink _ [] = [] - sink sunk (b:bs) = - pprTrace "sink" (ppr l) $ - blockJoin first final_middle last : sink sunk' bs - where - l = entryLabel b - (first, middle, last) = blockSplit b - (middle', assigs) = walk (blockToList middle) emptyBlock - (mapFindWithDefault [] l sunk) - - (dropped_last, assigs') = partition (`conflictsWithLast` last) assigs - - final_middle = foldl blockSnoc middle' (toNodes dropped_last) - - sunk' = mapUnion sunk $ - mapFromList [ (l, filt assigs' (getLive l)) - | l <- successors last ] - where - getLive l = mapFindWithDefault Set.empty l liveness - filt as live = [ (r,e) | (r,e) <- as, r `Set.member` live ] - - -walk :: [CmmNode O O] -> Block CmmNode O O -> [(LocalReg, CmmExpr)] - -> (Block CmmNode O O, [(LocalReg, CmmExpr)]) - -walk [] acc as = (acc, as) -walk (n:ns) acc as - | Just a <- collect_it = walk ns acc (a:as) - | otherwise = walk ns (foldr (flip blockSnoc) acc (n:drop_nodes)) as' - where - collect_it = case n of - CmmAssign (CmmLocal r) e@(CmmReg (CmmGlobal _)) -> Just (r,e) --- CmmAssign (CmmLocal r) e@(CmmLoad addr _) | --- foldRegsUsed (\b r -> False) True addr -> Just (r,e) - _ -> Nothing - - drop_nodes = toNodes dropped - (dropped, as') = partition should_drop as - where should_drop a = a `conflicts` n - -toNodes :: [(LocalReg,CmmExpr)] -> [CmmNode O O] -toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ] - --- We only sink "r = G" assignments right now, so conflicts is very simple: -conflicts :: (LocalReg,CmmExpr) -> CmmNode O O -> Bool -(_, rhs) `conflicts` CmmAssign reg _ | reg `regUsedIn` rhs = True ---(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True -(r, _) `conflicts` node - = foldRegsUsed (\b r' -> r == r' || b) False node - -conflictsWithLast :: (LocalReg,CmmExpr) -> CmmNode O C -> Bool -(r, _) `conflictsWithLast` node - = foldRegsUsed (\b r' -> r == r' || b) False node diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index bb8d5b2f22..f2a2855d7b 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -9,7 +9,6 @@ module CmmPipeline ( cmmPipeline ) where -import CLabel import Cmm import CmmLint import CmmBuildInfoTables @@ -17,76 +16,42 @@ import CmmCommonBlockElim import CmmProcPoint import CmmContFlowOpt import CmmLayoutStack +import CmmSink +import Hoopl import UniqSupply import DynFlags import ErrUtils import HscTypes -import Data.Maybe import Control.Monad import Outputable -import qualified Data.Set as Set -import Data.Map (Map) - ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline ----------------------------------------------------------------------------- --- There are two complications here: --- 1. We need to compile the procedures in two stages because we need --- an analysis of the procedures to tell us what CAFs they use. --- The first stage returns a map from procedure labels to CAFs, --- along with a closure that will compute SRTs and attach them to --- the compiled procedures. --- The second stage is to combine the CAF information into a top-level --- CAF environment mapping non-static closures to the CAFs they keep live, --- then pass that environment to the closures returned in the first --- stage of compilation. --- 2. We need to thread the module's SRT around when the SRT tables --- are computed for each procedure. --- The SRT needs to be threaded because it is grown lazily. --- 3. We run control flow optimizations twice, once before any pipeline --- work is done, and once again at the very end on all of the --- resulting C-- blocks. EZY: It's unclear whether or not whether --- we actually need to do the initial pass. + cmmPipeline :: HscEnv -- Compilation env including -- dynamic flags: -dcmm-lint -ddump-cps-cmm -> TopSRT -- SRT table and accumulating list of compiled procs -> CmmGroup -- Input C-- with Procedures -> IO (TopSRT, CmmGroup) -- Output CPS transformed C-- + cmmPipeline hsc_env topSRT prog = do let dflags = hsc_dflags hsc_env - -- - showPass dflags "CPSZ" - - (cafEnvs, tops) <- {-# SCC "tops" #-} liftM unzip $ mapM (cpsTop hsc_env) prog - -- tops :: [[(CmmDecl,CAFSet]] (one list per group) - let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs) - - -- folding over the groups - (topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops topCAFEnv) (topSRT, []) tops + showPass dflags "CPSZ" - let cmms :: CmmGroup - cmms = reverse (concat tops) + tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog + (topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) return (topSRT, cmms) -{- [Note global fuel] -~~~~~~~~~~~~~~~~~~~~~ -The identity and the last pass are stored in -mutable reference cells in an 'HscEnv' and are -global to one compiler session. --} --- EZY: It might be helpful to have an easy way of dumping the "pre" --- input for any given phase, besides just turning it all on with --- -ddump-cmmz -cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)]) -cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)]) +cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) +cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = do ----------- Control-flow optimisations --------------- @@ -110,8 +75,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) runUniqSM $ cmmLayoutStack procPoints entry_off g dump Opt_D_dump_cmmz_sp "Layout Stack" g --- g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g --- dump Opt_D_dump_cmmz_rewrite "Sink assignments" g + g <- if optLevel dflags >= 99 + then do g <- {-# SCC "sink" #-} return (cmmSink g) + dump Opt_D_dump_cmmz_rewrite "Sink assignments" g + g <- {-# SCC "inline" #-} return (cmmPeepholeInline g) + dump Opt_D_dump_cmmz_rewrite "Peephole inline" g + return g + else return g -- ----------- Sink and inline assignments ------------------- -- g <- {-# SCC "rewriteAssignments" #-} runOptimization $ @@ -126,31 +96,21 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g) dumps Opt_D_dump_cmmz_split "Post splitting" gs - ------------- More CAFs ------------------------------ + ------------- CAF analysis ------------------------------ let cafEnv = {-# SCC "cafAnal" #-} cafAnal g - let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs - mbpprTrace "localCAFs" (ppr localCAFs) $ return () - -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES + ------------- Populate info tables with stack info ------ gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap stackmaps) gs dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs - ----------- Control-flow optimisations --------------- + ----------- Control-flow optimisations ----------------- gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs - gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs - dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs - - return (localCAFs, gs) - - -- gs :: [ (CAFSet, CmmDecl) ] - -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?) + return (cafEnv, gs) where dflags = hsc_dflags hsc_env - mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z - | otherwise = z dump = dumpGraph dflags dumps flag name @@ -182,14 +142,3 @@ dumpWith dflags flag txt g = do when (not (dopt flag dflags)) $ dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) --- This probably belongs in CmmBuildInfoTables? --- We're just finishing the job here: once we know what CAFs are defined --- in non-static closures, we can build the SRTs. -toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]]) - -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]]) -toTops topCAFEnv (topSRT, tops) gs = - do let setSRT (topSRT, rst) g = - do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g - return (topSRT, gs : rst) - (topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs - return (topSRT, concat gs' : tops) diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs new file mode 100644 index 0000000000..fde34dc253 --- /dev/null +++ b/compiler/cmm/CmmSink.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE GADTs #-} +module CmmSink ( + cmmSink, + cmmPeepholeInline + ) where + +import Cmm +import BlockId +import CmmLive +import CmmUtils +import Hoopl + +import UniqFM +import Unique +import Outputable + +import qualified Data.Set as Set + +-- ----------------------------------------------------------------------------- +-- Sinking + +-- This is an optimisation pass that +-- (a) moves assignments closer to their uses, to reduce register pressure +-- (b) pushes assignments into a single branch of a conditional if possible + +-- It is particularly helpful in the Cmm generated by the Stg->Cmm +-- code generator, in which every function starts with a copyIn +-- sequence like: +-- +-- x1 = R1 +-- x2 = Sp[8] +-- x3 = Sp[16] +-- if (Sp - 32 < SpLim) then L1 else L2 +-- +-- we really want to push the x1..x3 assignments into the L2 branch. +-- +-- Algorithm: +-- +-- * Start by doing liveness analysis. +-- * Keep a list of assignments; earlier ones may refer to later ones +-- * Walk forwards through the graph; +-- * At an assignment: +-- * pick up the assignment and add it to the list +-- * At a store: +-- * drop any assignments that the store refers to +-- * drop any assignments that refer to memory that may be written +-- by the store +-- * do this recursively, dropping dependent assignments +-- * At a multi-way branch: +-- * drop any assignments that are live on more than one branch +-- * if any successor has more than one predecessor, drop everything +-- live in that successor +-- +-- As a side-effect we'll delete some dead assignments (transitively, +-- even). Maybe we could do without removeDeadAssignments? + +-- If we do this *before* stack layout, we might be able to avoid +-- saving some things across calls/procpoints. +-- +-- *but*, that will invalidate the liveness analysis, and we'll have +-- to re-do it. + +cmmSink :: CmmGraph -> CmmGraph +cmmSink graph = cmmSink' (cmmLiveness graph) graph + +type Assignment = (LocalReg, CmmExpr, AbsAddr) + +cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph +cmmSink' liveness graph + = ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph + where + + sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock] + sink _ [] = [] + sink sunk (b:bs) = + pprTrace "sink" (ppr lbl) $ + blockJoin first final_middle last : sink sunk' bs + where + lbl = entryLabel b + (first, middle, last) = blockSplit b + (middle', assigs) = walk (blockToList middle) emptyBlock + (mapFindWithDefault [] lbl sunk) + + getLive l = mapFindWithDefault Set.empty l liveness + lives = map getLive (successors last) + + -- multilive is a list of registers that are live in more than + -- one successor branch, and we should therefore drop them here. + multilive = [ r | (r,n) <- ufmToList livemap, n > 1 ] + where livemap = foldr (\r m -> addToUFM_C (+) m r (1::Int)) + emptyUFM (concatMap Set.toList lives) + + (dropped_last, assigs') = dropAssignments drop_if assigs + + drop_if a@(r,_,_) = a `conflicts` last || getUnique r `elem` multilive + + final_middle = foldl blockSnoc middle' dropped_last + + sunk' = mapUnion sunk $ + mapFromList [ (l, filterAssignments (getLive l) assigs') + | l <- successors last ] + + +filterAssignments :: RegSet -> [Assignment] -> [Assignment] +filterAssignments live assigs = reverse (go assigs []) + where go [] kept = kept + go (a@(r,_,_):as) kept | needed = go as (a:kept) + | otherwise = go as kept + where + needed = r `Set.member` live || any (a `conflicts`) (map toNode kept) + + +walk :: [CmmNode O O] -> Block CmmNode O O -> [Assignment] + -> (Block CmmNode O O, [Assignment]) + +walk [] block as = (block, as) +walk (n:ns) block as + | Just a <- shouldSink n = walk ns block (a : as) + | otherwise = walk ns block' as' + where + (dropped, as') = dropAssignments (`conflicts` n) as + block' = foldl blockSnoc block dropped `blockSnoc` n + +shouldSink :: CmmNode O O -> Maybe Assignment +shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprAddr e) + where no_local_regs = foldRegsUsed (\_ _ -> False) True e +shouldSink _other = Nothing + +toNode :: Assignment -> CmmNode O O +toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs + +dropAssignments :: (Assignment -> Bool) -> [Assignment] -> ([CmmNode O O], [Assignment]) +dropAssignments should_drop assigs + = (dropped, reverse kept) + where + (dropped,kept) = go assigs [] [] + + go [] dropped kept = (dropped, kept) + go (assig : rest) dropped kept + | conflict = go rest (toNode assig : dropped) kept + | otherwise = go rest dropped (assig:kept) + where + conflict = should_drop assig || any (assig `conflicts`) dropped + +-- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment +-- @r = e@ can be safely commuted past @stmt@. +-- +-- We only sink "r = G" assignments right now, so conflicts is very simple: +-- +conflicts :: Assignment -> CmmNode O x -> Bool +(_, rhs, _ ) `conflicts` CmmAssign reg _ | reg `regUsedIn` rhs = True +(_, _, addr) `conflicts` CmmStore addr' _ | addrConflicts addr (loadAddr addr') = True +(r, _, _) `conflicts` node + = foldRegsUsed (\b r' -> r == r' || b) False node + +-- An abstraction of the addresses read or written. +data AbsAddr = NoAddr | HeapAddr | StackAddr | AnyAddr + +bothAddrs :: AbsAddr -> AbsAddr -> AbsAddr +bothAddrs NoAddr x = x +bothAddrs x NoAddr = x +bothAddrs HeapAddr HeapAddr = HeapAddr +bothAddrs StackAddr StackAddr = StackAddr +bothAddrs _ _ = AnyAddr + +addrConflicts :: AbsAddr -> AbsAddr -> Bool +addrConflicts NoAddr _ = False +addrConflicts _ NoAddr = False +addrConflicts HeapAddr StackAddr = False +addrConflicts StackAddr HeapAddr = False +addrConflicts _ _ = True + +exprAddr :: CmmExpr -> AbsAddr -- here NoAddr means "no reads" +exprAddr (CmmLoad addr _) = loadAddr addr +exprAddr (CmmMachOp _ es) = foldr bothAddrs NoAddr (map exprAddr es) +exprAddr _ = NoAddr + +absAddr :: CmmExpr -> AbsAddr -- here NoAddr means "don't know" +absAddr (CmmLoad addr _) = bothAddrs HeapAddr (loadAddr addr) -- (1) +absAddr (CmmMachOp _ es) = foldr bothAddrs NoAddr (map absAddr es) +absAddr (CmmReg r) = regAddr r +absAddr (CmmRegOff r _) = regAddr r +absAddr _ = NoAddr + +loadAddr :: CmmExpr -> AbsAddr +loadAddr e = case absAddr e of + NoAddr -> HeapAddr -- (2) + a -> a + +-- (1) we assume that an address read from memory is a heap address. +-- We never read a stack address from memory. +-- +-- (2) loading from an unknown address is assumed to be a heap load. + +regAddr :: CmmReg -> AbsAddr +regAddr (CmmGlobal Sp) = StackAddr +regAddr (CmmGlobal Hp) = HeapAddr +regAddr _ = NoAddr + +-- After sinking, if we have an assignment to a temporary that is used +-- exactly once, then it will either be of the form +-- +-- x = E +-- .. stmt involving x .. +-- +-- OR +-- +-- x = E +-- .. stmt conflicting with E .. + +-- So the idea in peepholeInline is to spot the first case +-- (recursively) and inline x. We start with the set of live +-- registers and move backwards through the block. +-- +-- ToDo: doesn't inline into the last node +-- +cmmPeepholeInline :: CmmGraph -> CmmGraph +cmmPeepholeInline graph = ofBlockList (g_entry graph) $ map do_block (toBlockList graph) + where + liveness = cmmLiveness graph + + do_block :: Block CmmNode C C -> Block CmmNode C C + do_block block = blockJoin first (go rmiddle live_middle) last + where + (first, middle, last) = blockSplit block + rmiddle = reverse (blockToList middle) + + live = Set.unions [ mapFindWithDefault Set.empty l liveness | l <- successors last ] + + live_middle = gen_kill last live + + go :: [CmmNode O O] -> RegSet -> Block CmmNode O O + go [] _ = emptyBlock + go [stmt] _ = blockCons stmt emptyBlock + go (stmt : rest) live = tryInline stmt usages live rest + where + usages :: UniqFM Int + usages = foldRegsUsed addUsage emptyUFM stmt + + addUsage :: UniqFM Int -> LocalReg -> UniqFM Int + addUsage m r = addToUFM_C (+) m r 1 + + tryInline stmt usages live (CmmAssign (CmmLocal l) rhs : rest) + | not (l `elemRegSet` live), + Just 1 <- lookupUFM usages l = tryInline stmt' usages' live' rest + where live' = foldRegsUsed extendRegSet live rhs + usages' = foldRegsUsed addUsage usages rhs + + stmt' = mapExpDeep inline stmt + where inline (CmmReg (CmmLocal l')) | l == l' = rhs + inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset rhs off + inline other = other + + tryInline stmt _usages live stmts + = go stmts (gen_kill stmt live) `blockSnoc` stmt + diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 31c1794887..132f291540 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -231,13 +231,18 @@ pprNode node = pp_node <+> pp_debug CmmCall tgt k regs out res updfr_off -> hcat [ ptext (sLit "call"), space , pprFun tgt, parens (interpp'SP regs), space - , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) - <+> parens (ppr res) - , ptext (sLit " with update frame") <+> ppr updfr_off + , returns <+> + ptext (sLit "args: ") <> ppr out <> comma <+> + ptext (sLit "res: ") <> ppr res <> comma <+> + ptext (sLit "upd: ") <> ppr updfr_off , semi ] where pprFun f@(CmmLit _) = ppr f pprFun f = parens (ppr f) + returns + | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma + | otherwise = empty + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space @@ -245,7 +250,7 @@ pprNode node = pp_node <+> pp_debug , ptext (sLit "returns to") <+> ppr s <+> ptext (sLit "args:") <+> parens (ppr as) <+> ptext (sLit "ress:") <+> parens (ppr rs) - , ptext (sLit " with update frame") <+> ppr u + , ptext (sLit "upd:") <+> ppr u , semi ] pp_debug :: SDoc diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 2a4486eb69..ff3cfc5189 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -423,6 +423,7 @@ isGoodBreakExpr (HsApp {}) = True isGoodBreakExpr (OpApp {}) = True isGoodBreakExpr (NegApp {}) = True isGoodBreakExpr (HsIf {}) = True +isGoodBreakExpr (HsMultiIf {}) = True isGoodBreakExpr (HsCase {}) = True isGoodBreakExpr (RecordCon {}) = True isGoodBreakExpr (RecordUpd {}) = True @@ -458,6 +459,8 @@ addTickHsExpr e@(HsOverLit _) = return e addTickHsExpr e@(HsLit _) = return e addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase ty mgs) = + liftM (HsLamCase ty) (addTickMatchGroup True mgs) addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) addTickHsExpr (OpApp e1 e2 fix e3) = @@ -494,6 +497,10 @@ addTickHsExpr (HsIf cnd e1 e2 e3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of [_] -> False; _ -> True + ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts + ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet binds e) = bindLocals (collectLocalBinders binds) $ liftM2 HsLet diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 11fa5d53c9..8c53c1aea1 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -205,6 +205,15 @@ dsExpr (NegApp expr neg_expr) dsExpr (HsLam a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr a_Match +dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty)) + | isEmptyMatchGroup matches -- A Core 'case' is always non-empty + = -- So desugar empty HsLamCase to error call + mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case")) + | otherwise + = do { arg_var <- newSysLocalDs arg + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches + ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } + dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg \end{code} @@ -328,6 +337,19 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr) Just fun -> do { core_fun <- dsExpr fun ; return (mkCoreApps core_fun [pred,b1,b2]) } Nothing -> return $ mkIfThenElse pred b1 b2 } + +dsExpr (HsMultiIf res_ty alts) + | null alts + = mkErrorExpr + + | otherwise + = do { match_result <- liftM (foldr1 combineMatchResults) + (mapM (dsGRHS IfAlt res_ty) alts) + ; error_expr <- mkErrorExpr + ; extractMatchResult match_result error_expr } + where + mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty + (ptext (sLit "multi-way if")) \end{code} diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index ed87d186af..9e84e46e9f 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -6,7 +6,7 @@ Matching guarded right-hand-sides (GRHSs) \begin{code} -module DsGRHSs ( dsGuarded, dsGRHSs ) where +module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where #include "HsVersions.h" @@ -55,8 +55,8 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon -> GRHSs Id -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do - match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss +dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do + match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs @@ -66,8 +66,8 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do -- return match_result2 -dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult -dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) +dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult +dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty \end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 9a1d050fb2..4d07c8c34e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -864,6 +864,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } repE (HsLam (MatchGroup [m] _)) = repLambda m +repE (HsLamCase _ (MatchGroup ms _)) + = do { ms' <- mapM repMatchTup ms + ; repLamCase (nonEmptyCoreList ms') } repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op _ e2) = @@ -878,14 +881,19 @@ repE (NegApp x _) = do repE (HsPar x) = repLE x repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; repCaseE arg (nonEmptyCoreList ms2) } +repE (HsCase e (MatchGroup ms _)) + = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; repCaseE arg (nonEmptyCoreList ms2) } repE (HsIf _ x y z) = do a <- repLE x b <- repLE y c <- repLE z repCond a b c +repE (HsMultiIf _ alts) + = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList alts') + ; wrapGenSyms (concat binds) expr' } repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 @@ -976,22 +984,22 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] - = do {a <- repLE e; repNormal a } -repGuards other - = do { zs <- mapM process other; - let {(xs, ys) = unzip zs}; - gd <- repGuarded (nonEmptyCoreList ys); - wrapGenSyms (concat xs) gd } - where - process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) - process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2)) - = do { x <- repLNormalGE e1 e2; - return ([], x) } - process (L _ (GRHS ss rhs)) - = do (gs, ss') <- repLSts ss - rhs' <- addBinds gs $ repLE rhs - g <- repPatGE (nonEmptyCoreList ss') rhs' - return (gs, g) + = do { a <- repLE e + ; repNormal a } +repGuards alts + = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts + ; body <- repGuarded (nonEmptyCoreList alts') + ; wrapGenSyms (concat binds) body } + +repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) +repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs)) + = do { guarded <- repLNormalGE guard rhs + ; return ([], guarded) } +repLGRHS (L _ (GRHS stmts rhs)) + = do { (gs, stmts') <- repLSts stmts + ; rhs' <- addBinds gs $ repLE rhs + ; guarded <- repPatGE (nonEmptyCoreList stmts') rhs' + ; return (gs, guarded) } repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) @@ -1455,6 +1463,9 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y] repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] +repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) +repLamCase (MkC ms) = rep2 lamCaseEName [ms] + repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] @@ -1464,6 +1475,9 @@ repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] +repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) +repMultiIf (MkC alts) = rep2 multiIfEName [alts] + repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] @@ -1893,9 +1907,9 @@ templateHaskellNames = [ clauseName, -- Exp varEName, conEName, litEName, appEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, + infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, unboxedTupEName, - condEName, letEName, caseEName, doEName, compEName, + condEName, multiIfEName, letEName, caseEName, doEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, -- FieldExp @@ -2058,8 +2072,9 @@ clauseName = libFun (fsLit "clause") clauseIdKey -- data Exp = ... varEName, conEName, litEName, appEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName, - letEName, caseEName, doEName, compEName :: Name + sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, + unboxedTupEName, condEName, multiIfEName, letEName, caseEName, + doEName, compEName :: Name varEName = libFun (fsLit "varE") varEIdKey conEName = libFun (fsLit "conE") conEIdKey litEName = libFun (fsLit "litE") litEIdKey @@ -2069,9 +2084,11 @@ infixAppName = libFun (fsLit "infixApp") infixAppIdKey sectionLName = libFun (fsLit "sectionL") sectionLIdKey sectionRName = libFun (fsLit "sectionR") sectionRIdKey lamEName = libFun (fsLit "lamE") lamEIdKey +lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey tupEName = libFun (fsLit "tupE") tupEIdKey unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey condEName = libFun (fsLit "condE") condEIdKey +multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey letEName = libFun (fsLit "letE") letEIdKey caseEName = libFun (fsLit "caseE") caseEIdKey doEName = libFun (fsLit "doE") doEIdKey @@ -2370,8 +2387,8 @@ clauseIdKey = mkPreludeMiscIdUnique 262 -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, - sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey, - condEIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, + unboxedTupEIdKey, condEIdKey, multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique @@ -2384,21 +2401,23 @@ infixAppIdKey = mkPreludeMiscIdUnique 275 sectionLIdKey = mkPreludeMiscIdUnique 276 sectionRIdKey = mkPreludeMiscIdUnique 277 lamEIdKey = mkPreludeMiscIdUnique 278 -tupEIdKey = mkPreludeMiscIdUnique 279 -unboxedTupEIdKey = mkPreludeMiscIdUnique 280 -condEIdKey = mkPreludeMiscIdUnique 281 -letEIdKey = mkPreludeMiscIdUnique 282 -caseEIdKey = mkPreludeMiscIdUnique 283 -doEIdKey = mkPreludeMiscIdUnique 284 -compEIdKey = mkPreludeMiscIdUnique 285 -fromEIdKey = mkPreludeMiscIdUnique 286 -fromThenEIdKey = mkPreludeMiscIdUnique 287 -fromToEIdKey = mkPreludeMiscIdUnique 288 -fromThenToEIdKey = mkPreludeMiscIdUnique 289 -listEIdKey = mkPreludeMiscIdUnique 290 -sigEIdKey = mkPreludeMiscIdUnique 291 -recConEIdKey = mkPreludeMiscIdUnique 292 -recUpdEIdKey = mkPreludeMiscIdUnique 293 +lamCaseEIdKey = mkPreludeMiscIdUnique 279 +tupEIdKey = mkPreludeMiscIdUnique 280 +unboxedTupEIdKey = mkPreludeMiscIdUnique 281 +condEIdKey = mkPreludeMiscIdUnique 282 +multiIfEIdKey = mkPreludeMiscIdUnique 283 +letEIdKey = mkPreludeMiscIdUnique 284 +caseEIdKey = mkPreludeMiscIdUnique 285 +doEIdKey = mkPreludeMiscIdUnique 286 +compEIdKey = mkPreludeMiscIdUnique 287 +fromEIdKey = mkPreludeMiscIdUnique 288 +fromThenEIdKey = mkPreludeMiscIdUnique 289 +fromToEIdKey = mkPreludeMiscIdUnique 290 +fromThenToEIdKey = mkPreludeMiscIdUnique 291 +listEIdKey = mkPreludeMiscIdUnique 292 +sigEIdKey = mkPreludeMiscIdUnique 293 +recConEIdKey = mkPreludeMiscIdUnique 294 +recUpdEIdKey = mkPreludeMiscIdUnique 295 -- type FieldExp = ... fieldExpIdKey :: Unique diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index c80446a751..8fd3a203f3 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -88,6 +88,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs incomplete_flag :: HsMatchContext id -> Bool incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag IfAlt = False incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 04735ed1b9..13e58d13e4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -186,6 +186,7 @@ Library CmmParse CmmProcPoint CmmRewriteAssignments + CmmSink CmmType CmmUtils CmmLayoutStack diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 3ad5aa03fa..abcdb3ed40 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -482,6 +482,12 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } + cvt (LamCaseE ms) + | null ms = failWith (ptext (sLit "Lambda-case expression with no alternatives")) + | otherwise = do { ms' <- mapM cvtMatch ms + ; return $ HsLamCase placeHolderType + (mkMatchGroup ms') + } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) @@ -489,6 +495,10 @@ cvtl e = wrapL (cvt e) cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } + cvt (MultiIfE alts) + | null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives")) + | otherwise = do { alts' <- mapM cvtpair alts + ; return $ HsMultiIf placeHolderType alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds ; e' <- cvtl e; return $ HsLet ds' e' } cvt (CaseE e ms) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 390898000d..bac9ec6348 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -435,7 +435,7 @@ data TyClDecl name | -- | @type/data declaration TyDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an assoicated type + , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type -- these include outer binders -- Eg class T a where -- type F a :: * diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index dcfcb9f8f0..12a5fad800 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -113,6 +113,8 @@ data HsExpr id | HsLam (MatchGroup id) -- Currently always a single match + | HsLamCase PostTcType (MatchGroup id) -- Lambda-case + | HsApp (LHsExpr id) (LHsExpr id) -- Application -- Operator applications: @@ -150,6 +152,8 @@ data HsExpr id (LHsExpr id) -- then part (LHsExpr id) -- else part + | HsMultiIf PostTcType [LGRHS id] -- Multi-way if + | HsLet (HsLocalBinds id) -- let(rec) (LHsExpr id) @@ -448,6 +452,10 @@ ppr_expr (ExplicitTuple exprs boxity) ppr_expr (HsLam matches) = pprMatches (LambdaExpr :: HsMatchContext id) matches +ppr_expr (HsLamCase _ matches) + = sep [ sep [ptext (sLit "\\case {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + ppr_expr (HsCase expr matches) = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] @@ -458,6 +466,12 @@ ppr_expr (HsIf _ e1 e2 e3) ptext (sLit "else"), nest 4 (ppr e3)] +ppr_expr (HsMultiIf _ alts) + = sep $ ptext (sLit "if") : map ppr_alt alts + where ppr_alt (L _ (GRHS guards expr)) = + sep [ char '|' <+> interpp'SP guards + , ptext (sLit "->") <+> pprDeeper (ppr expr) ] + -- special case: let ... in let ... ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), @@ -1107,7 +1121,7 @@ pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) = ptext (sLit "rec") <+> - vcat [ braces (vcat (map ppr segment)) + vcat [ ppr_do_stmts segment , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids , ptext (sLit "later_ids=") <> ppr later_ids])] @@ -1139,7 +1153,7 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc +ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR) => [LStmtLR idL idR] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs ppr_do_stmts stmts @@ -1257,6 +1271,7 @@ data HsMatchContext id -- Context of a Match = FunRhs id Bool -- Function binding for f; True <=> written infix | LambdaExpr -- Patterns of a lambda | CaseAlt -- Patterns and guards on a case alternative + | IfAlt -- Guards of a multi-way if alternative | ProcExpr -- Patterns of a proc | PatBindRhs -- A pattern binding eg [y] <- e = e @@ -1307,6 +1322,7 @@ isMonadCompExpr _ = False matchSeparator :: HsMatchContext id -> SDoc matchSeparator (FunRhs {}) = ptext (sLit "=") matchSeparator CaseAlt = ptext (sLit "->") +matchSeparator IfAlt = ptext (sLit "->") matchSeparator LambdaExpr = ptext (sLit "->") matchSeparator ProcExpr = ptext (sLit "->") matchSeparator PatBindRhs = ptext (sLit "=") @@ -1329,6 +1345,7 @@ pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for") <+> quotes (ppr fun) pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") +pprMatchContextNoun IfAlt = ptext (sLit "multi-way if alternative") pprMatchContextNoun RecUpd = ptext (sLit "record-update construct") pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation") pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding") @@ -1377,6 +1394,7 @@ pprStmtContext (TransStmtCtxt c) matchContextErrString :: Outputable id => HsMatchContext id -> SDoc matchContextErrString (FunRhs fun _) = ptext (sLit "function") <+> ppr fun matchContextErrString CaseAlt = ptext (sLit "case") +matchContextErrString IfAlt = ptext (sLit "multi-way if") matchContextErrString PatBindRhs = ptext (sLit "pattern binding") matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString LambdaExpr = ptext (sLit "lambda") diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index c484b0637f..225a3c812b 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -37,11 +37,13 @@ module IfaceType ( import Coercion import TypeRep hiding( maybeParen ) +import Unique( hasKey ) import TyCon import Id import Var import TysWiredIn import TysPrim +import PrelNames( funTyConKey ) import Name import BasicTypes import Outputable @@ -352,7 +354,10 @@ toIfaceContext = toIfaceTypes ---------------- coToIfaceType :: Coercion -> IfaceType coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty] -coToIfaceType (TyConAppCo tc cos) = IfaceTyConApp (toIfaceTyCon tc) +coToIfaceType (TyConAppCo tc cos) + | tc `hasKey` funTyConKey + , [arg,res] <- cos = IfaceFunTy (coToIfaceType arg) (coToIfaceType res) + | otherwise = IfaceTyConApp (toIfaceTyCon tc) (map coToIfaceType cos) coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) (coToIfaceType co2) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 690b77ea4a..314efb95f1 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -486,6 +486,8 @@ data ExtensionFlag | Opt_NondecreasingIndentation | Opt_RelaxedLayout | Opt_TraditionalRecordSyntax + | Opt_LambdaCase + | Opt_MultiWayIf deriving (Eq, Enum, Show) -- | Contains not only a collection of 'DynFlag's but also a plethora of @@ -1016,7 +1018,7 @@ defaultLogAction :: LogAction defaultLogAction dflags severity srcSpan style msg = case severity of SevOutput -> printSDoc msg style - SevDump -> hPrintDump dflags stdout msg + SevDump -> printSDoc (msg $$ blankLine) style SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' @@ -2165,6 +2167,8 @@ xFlags = [ ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), ( "RelaxedLayout", Opt_RelaxedLayout, nop ), ( "TraditionalRecordSyntax", Opt_TraditionalRecordSyntax, nop ), + ( "LambdaCase", Opt_LambdaCase, nop ), + ( "MultiWayIf", Opt_MultiWayIf, nop ), ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), ( "RelaxedPolyRec", Opt_RelaxedPolyRec, \ turn_on -> if not turn_on diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index daa66f9d2f..1643128eb7 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -230,6 +230,9 @@ mkDumpDoc hdr doc -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. -- otherwise emit to stdout. +-- +-- When hdr is empty, we print in a more compact format (no separators and +-- blank lines) dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpSDoc dflags dflag hdr doc = do let mFile = chooseDumpFile dflags dflag @@ -247,12 +250,18 @@ dumpSDoc dflags dflag hdr doc writeIORef gdref (Set.insert fileName gd) createDirectoryIfMissing True (takeDirectory fileName) handle <- openFile fileName mode - hPrintDump dflags handle doc + let doc' + | null hdr = doc + | otherwise = doc $$ blankLine + defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle hClose handle -- write the dump to stdout - Nothing - -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) + Nothing -> do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + log_action dflags dflags severity noSrcSpan defaultDumpStyle doc' -- | Choose where to put a dump file based on DynFlags diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index df400f574a..cef5974fb0 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -500,6 +500,7 @@ data Token | ITdcolon | ITequal | ITlam + | ITlcase | ITvbar | ITlarrow | ITrarrow @@ -979,23 +980,37 @@ splitQualName orig_buf len parens = split orig_buf orig_buf varid :: Action varid span buf len = - fs `seq` case lookupUFM reservedWordsFM fs of - Just (keyword,0) -> do - maybe_layout keyword - return (L span keyword) - Just (keyword,exts) -> do - b <- extension (\i -> exts .&. i /= 0) - if b then do maybe_layout keyword - return (L span keyword) - else return (L span (ITvarid fs)) - _other -> return (L span (ITvarid fs)) + Just (ITcase, _) -> do + lambdaCase <- extension lambdaCaseEnabled + keyword <- if lambdaCase + then do + lastTk <- getLastTk + return $ case lastTk of + Just ITlam -> ITlcase + _ -> ITcase + else + return ITcase + maybe_layout keyword + return $ L span keyword + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, exts) -> do + extsEnabled <- extension $ \i -> exts .&. i /= 0 + if extsEnabled + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs where - fs = lexemeToFastString buf len + !fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token -conid buf len = ITconid fs - where fs = lexemeToFastString buf len +conid buf len = ITconid $! lexemeToFastString buf len qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token qvarsym buf len = ITqvarsym $! splitQualName buf len False @@ -1007,17 +1022,18 @@ varsym, consym :: Action varsym = sym ITvarsym consym = sym ITconsym -sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int - -> P (RealLocated Token) +sym :: (FastString -> Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,exts) -> do - b <- extension exts - if b then return (L span keyword) - else return (L span $! con fs) - _other -> return (L span $! con fs) + Just (keyword, exts) -> do + extsEnabled <- extension exts + let !tk | extsEnabled = keyword + | otherwise = con fs + return $ L span tk + Nothing -> + return $ L span $! con fs where - fs = lexemeToFastString buf len + !fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (Integer -> Token) @@ -1094,6 +1110,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then where f ITdo = pushLexState layout_do f ITmdo = pushLexState layout_do f ITof = pushLexState layout + f ITlcase = pushLexState layout f ITlet = pushLexState layout f ITwhere = pushLexState layout f ITrec = pushLexState layout @@ -1520,6 +1537,7 @@ data PState = PState { buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, + last_tk :: Maybe Token, last_loc :: RealSrcSpan, -- pos of previous token last_len :: !Int, -- len of previous token loc :: RealSrcLoc, -- current loc (end of prev token + 1) @@ -1624,6 +1642,12 @@ setLastToken loc len = P $ \s -> POk s { last_len=len } () +setLastTk :: Token -> P () +setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () + +getLastTk :: P (Maybe Token) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + data AlexInput = AI RealSrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char @@ -1839,6 +1863,10 @@ typeLiteralsBit :: Int typeLiteralsBit = 28 explicitNamespacesBit :: Int explicitNamespacesBit = 29 +lambdaCaseBit :: Int +lambdaCaseBit = 30 +multiWayIfBit :: Int +multiWayIfBit = 31 always :: Int -> Bool @@ -1888,6 +1916,10 @@ typeLiteralsEnabled flags = testBit flags typeLiteralsBit explicitNamespacesEnabled :: Int -> Bool explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit +lambdaCaseEnabled :: Int -> Bool +lambdaCaseEnabled flags = testBit flags lambdaCaseBit +multiWayIfEnabled :: Int -> Bool +multiWayIfEnabled flags = testBit flags multiWayIfBit -- PState for parsing options pragmas -- @@ -1904,6 +1936,7 @@ mkPState flags buf loc = buffer = buf, dflags = flags, messages = emptyMessages, + last_tk = Nothing, last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, @@ -1947,6 +1980,8 @@ mkPState flags buf loc = .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags + .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. multiWayIfBit `setBitIf` xopt Opt_MultiWayIf flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -2274,7 +2309,13 @@ lexToken = do let span = mkRealSrcSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes - t span buf bytes + lt <- t span buf bytes + case unLoc lt of + ITlineComment _ -> return lt + ITblockComment _ -> return lt + lt' -> do + setLastTk lt' + return lt reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 21f8782f6f..62132277d9 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -55,7 +55,7 @@ import FastString import Maybes ( orElse ) import Outputable -import Control.Monad ( unless ) +import Control.Monad ( unless, liftM ) import GHC.Exts import Data.Char import Control.Monad ( mplus ) @@ -275,6 +275,7 @@ incorrect. '::' { L _ ITdcolon } '=' { L _ ITequal } '\\' { L _ ITlam } + 'lcase' { L _ ITlcase } '|' { L _ ITvbar } '<-' { L _ ITlarrow } '->' { L _ ITrarrow } @@ -1388,9 +1389,13 @@ exp10 :: { LHsExpr RdrName } (unguardedGRHSs $6) ]) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } + | '\\' 'lcase' altslist + { LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> return (LL $ mkHsIf $2 $5 $8) } + | 'if' gdpats {% hintMultiWayIf (getLoc $1) >> + return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } @@ -2138,4 +2143,11 @@ fileSrcSpan = do l <- getSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState + unless mwiEnabled $ parseErrorSDoc span $ + text "Multi-way if-expressions need -XMultiWayIf turned on" } diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index d3d16033eb..2c70698fdd 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -25,7 +25,7 @@ module RnBinds ( -- Other bindings rnMethodBinds, renameSigs, mkSigTvFn, - rnMatchGroup, rnGRHSs, + rnMatchGroup, rnGRHSs, rnGRHS, makeMiniFixityEnv, MiniFixityEnv, HsSigCtxt(..) ) where diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 1868be9269..78a64344f3 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -29,7 +29,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) import RnSource ( rnSrcDecls, findSplice ) import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, makeMiniFixityEnv) + rnMatchGroup, rnGRHS, makeMiniFixityEnv) import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) @@ -224,6 +224,10 @@ rnExpr (HsLam matches) = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> return (HsLam matches', fvMatch) +rnExpr (HsLamCase arg matches) + = rnMatchGroup CaseAlt matches `thenM` \ (matches', fvs_ms) -> + return (HsLamCase arg matches', fvs_ms) + rnExpr (HsCase expr matches) = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) -> @@ -280,6 +284,10 @@ rnExpr (HsIf _ p b1 b2) ; (mb_ite, fvITE) <- lookupIfThenElse ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } +rnExpr (HsMultiIf ty alts) + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts + ; return (HsMultiIf ty alts', fvs) } + rnExpr (HsType a) = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index d8c6732c34..731f55128c 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -586,7 +586,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = WARN( debugIsOn && (max_iterations > 2) - , hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations + , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations <+> ptext (sLit "iterations") <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index df9013cd08..f2ed224df4 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1571,21 +1571,22 @@ tryRules env rules fn args call_cont where trace_dump dflags rule rule_rhs | dopt Opt_D_dump_rule_rewrites dflags - = liftIO . dumpSDoc dflags Opt_D_dump_rule_rewrites "" $ - vcat [text "Rule fired", - text "Rule:" <+> ftext (ru_name rule), - text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), - text "After: " <+> pprCoreExpr rule_rhs, - text "Cont: " <+> ppr call_cont] + = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ru_name rule) + , text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)) + , text "After: " <+> pprCoreExpr rule_rhs + , text "Cont: " <+> ppr call_cont ] | dopt Opt_D_dump_rule_firings dflags - = liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $ - vcat [text "Rule fired", - ftext (ru_name rule)] + = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ru_name rule) | otherwise = return () + log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $ + sep [text hdr, nest 4 details] + \end{code} Note [Rules for recursive functions] diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 498302a5e9..0cf858e7b5 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -726,7 +726,7 @@ match_co :: RuleEnv match_co renv subst (CoVarCo cv) co = match_var renv subst cv (Coercion co) match_co _ _ co1 _ - = pprTrace "match_co baling out" (ppr co1) Nothing + = pprTrace "match_co bailing out" (ppr co1) Nothing ------------- rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 284d0218f5..b013e258f3 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -364,30 +364,29 @@ newSCWorkFromFlavored d flavor cls xis | isGiven flavor = do { let sc_theta = immSuperClasses cls xis - xev = XEvTerm { ev_comp = panic "Can't compose for given!" - , ev_decomp = \x -> zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] } + xev_decomp x = zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] + xev = XEvTerm { ev_comp = panic "Can't compose for given!" + , ev_decomp = xev_decomp } ; ctevs <- xCtFlavor flavor sc_theta xev - ; emit_sc_flavs d ctevs } + + ; traceTcS "newSCWork/Given" $ ppr "ctevs =" <+> ppr ctevs + ; mapM_ emit_non_can ctevs } | isEmptyVarSet (tyVarsOfTypes xis) - = return () -- Wanteds/Derived with no variables yield no deriveds. + = return () -- Wanteds with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. + | otherwise -- Wanted case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis - impr_theta = filter is_improvement_pty sc_rec_theta - xev = panic "Derived's are not supposed to transform evidence!" - der_ev = Derived { ctev_wloc = ctev_wloc flavor, ctev_pred = ctev_pred flavor } - ; ctevs <- xCtFlavor der_ev impr_theta xev - ; emit_sc_flavs d ctevs } - -emit_sc_flavs :: SubGoalDepth -> [CtEvidence] -> TcS () -emit_sc_flavs d fls - = do { traceTcS "newSCWorkFromFlavored" $ - text "Emitting superclass work:" <+> ppr sc_cts - ; updWorkListTcS $ appendWorkListCt sc_cts } - where - sc_cts = map (\fl -> CNonCanonical { cc_ev = fl, cc_depth = d }) fls + impr_theta = filter is_improvement_pty sc_rec_theta + ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta + ; mapM_ emit_der impr_theta } + + where emit_der pty = newDerived (ctev_wloc flavor) pty >>= mb_emit + mb_emit Nothing = return () + mb_emit (Just ctev) = emit_non_can ctev + emit_non_can ctev = updWorkListTcS $ + extendWorkListCt (CNonCanonical ctev d) is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency @@ -507,7 +506,8 @@ flatten :: SubGoalDepth -- Depth flatten d f ctxt ty | Just ty' <- tcView ty = do { (xi, co) <- flatten d f ctxt ty' - ; return (xi,co) } + ; if eqType xi ty then return (ty,co) else return (xi,co) } + -- Small tweak for better error messages flatten _ _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 0a5d941adf..8d79e89d97 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -855,7 +855,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args Note [Getting base classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functor and Typeable are define in package 'base', and that is not available +Functor and Typeable are defined in package 'base', and that is not available when compiling 'ghc-prim'. So we must be careful that 'deriving' for stuff in ghc-prim does not use Functor or Typeable implicitly via these lookups. diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index f3c238bd66..51b5eb3fa7 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -201,6 +201,14 @@ tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty ; return (mkHsWrap co_fn (HsLam match')) } +tcExpr e@(HsLamCase _ matches) res_ty + = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty + ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty + ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' } + where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e) + , ptext (sLit "requires")] + match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } + tcExpr (ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty @@ -437,6 +445,11 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] -- and it maintains uniformity with other rebindable syntax ; return (HsIf (Just fun') pred' b1' b2') } +tcExpr (HsMultiIf _ alts) res_ty + = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + ; return $ HsMultiIf res_ty alts' } + where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + tcExpr (HsDo do_or_lc stmts _) res_ty = tcDoStmts do_or_lc stmts res_ty diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index aa444715b0..922b2cd404 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -557,6 +557,11 @@ zonkExpr env (HsLam matches) = zonkMatchGroup env matches `thenM` \ new_matches -> returnM (HsLam new_matches) +zonkExpr env (HsLamCase arg matches) + = zonkTcTypeToType env arg `thenM` \ new_arg -> + zonkMatchGroup env matches `thenM` \ new_matches -> + returnM (HsLamCase new_arg new_matches) + zonkExpr env (HsApp e1 e2) = zonkLExpr env e1 `thenM` \ new_e1 -> zonkLExpr env e2 `thenM` \ new_e2 -> @@ -616,6 +621,15 @@ zonkExpr env (HsIf e0 e1 e2 e3) ; new_e3 <- zonkLExpr env e3 ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) } +zonkExpr env (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocM zonk_alt) alts + ; ty' <- zonkTcTypeToType env ty + ; returnM $ HsMultiIf ty' alts' } + where zonk_alt (GRHS guard expr) + = do { (env', guard') <- zonkStmts env guard + ; expr' <- zonkLExpr env' expr + ; returnM $ GRHS guard' expr' } + zonkExpr env (HsLet binds expr) = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> zonkLExpr new_env expr `thenM` \ new_expr -> diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 2941a17092..acc20649c0 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -13,10 +13,10 @@ TcMatches: Typecheck some @Matches@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), TcStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt +module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase, + tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt ) where import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index f0c69c5819..4073e4e6f8 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -66,8 +66,8 @@ module TcSMonad ( InertSet(..), InertCans(..), getInertEqs, getCtCoercion, emptyInert, getTcSInerts, lookupInInerts, - extractUnsolved, - extractUnsolvedTcS, modifyInertTcS, + getInertUnsolved, getInertInsols, splitInertsForImplications, + modifyInertTcS, updInertSetTcS, partitionCCanMap, partitionEqMap, getRelevantCts, extractRelevantInerts, CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap, @@ -362,6 +362,13 @@ extractUnsolvedCMap cmap = in (wntd `unionBags` derd, cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) +extractWantedCMap :: CCanMap a -> (Cts, CCanMap a) +-- Gets the wanted /only/ constraints and returns a residual +-- CCanMap with only givens or derived +extractWantedCMap cmap = + let wntd = foldUFM unionBags emptyCts (cts_wanted cmap) + in (wntd, cmap { cts_wanted = emptyUFM }) + -- Maps from PredTypes to Constraints type CtTypeMap = TypeMap Ct @@ -655,64 +662,92 @@ modifyInertTcS upd ; return a } -extractUnsolvedTcS :: TcS (Cts,Cts) --- Extracts frozen errors and remaining unsolved and sets the --- inert set to be the remaining! -extractUnsolvedTcS = modifyInertTcS extractUnsolved - -extractUnsolved :: InertSet -> ((Cts,Cts), InertSet) --- Postcondition --- ------------- --- When: --- ((frozen,cts),is_solved) <- extractUnsolved inert --- Then: --- ----------------------------------------------------------------------------- --- cts | The unsolved (Derived or Wanted only) residual --- | canonical constraints, that is, no CNonCanonicals. --- -----------|----------------------------------------------------------------- --- frozen | The CNonCanonicals of the original inert (frozen errors), --- | of all flavors --- -----------|----------------------------------------------------------------- --- is_solved | Whatever remains from the inert after removing the previous two. --- ----------------------------------------------------------------------------- -extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs - , inert_eq_tvs = eq_tvs - , inert_irreds = irreds - , inert_funeqs = funeqs - , inert_dicts = dicts - } - , inert_frozen = frozen - , inert_solved = solved - , inert_flat_cache = flat_cache - , inert_solved_funeqs = funeq_cache - }) - - = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs - , inert_eq_tvs = eq_tvs - , inert_dicts = solved_dicts - , inert_irreds = solved_irreds - , inert_funeqs = solved_funeqs } - , inert_frozen = emptyCts -- All out - - -- At some point, I used to flush all the solved, in - -- fear of evidence loops. But I think we are safe, - -- flushing is why T3064 had become slower - , inert_solved = solved -- PredMap emptyTM - , inert_flat_cache = flat_cache -- FamHeadMap emptyTM - , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM - } - in ((frozen, unsolved), is_solved) - - where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs - unsolved_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ - eqs `minusVarEnv` solved_eqs - - (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenCt) irreds - (unsolved_dicts, solved_dicts) = extractUnsolvedCMap dicts - (unsolved_funeqs, solved_funeqs) = partCtFamHeadMap (not . isGivenCt) funeqs - - unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags` - unsolved_dicts `unionBags` unsolved_funeqs + +splitInertsForImplications :: InertSet -> ([Ct],InertSet) +-- Converts the Wanted of the original inert to Given and removes +-- all Wanted and Derived from the inerts. +-- DV: Is the removal of Derived essential? +splitInertsForImplications is + = let (cts,is') = extractWanted is + in (givens_from_unsolved cts,is') + where givens_from_unsolved = foldrBag get_unsolved [] + get_unsolved cc rest_givens + | pushable_wanted cc + = let fl = ctEvidence cc + gfl = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol + , ctev_evtm = EvId (ctev_evar fl) + , ctev_pred = ctev_pred fl } + this_given = cc { cc_ev = gfl } + in this_given : rest_givens + | otherwise = rest_givens + + pushable_wanted :: Ct -> Bool + pushable_wanted cc + = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications] + + -- Returns Wanted constraints and a Derived/Given InertSet + extractWanted (IS { inert_cans = IC { inert_eqs = eqs + , inert_eq_tvs = eq_tvs + , inert_irreds = irreds + , inert_funeqs = funeqs + , inert_dicts = dicts + } + , inert_frozen = _frozen + , inert_solved = solved + , inert_flat_cache = flat_cache + , inert_solved_funeqs = funeq_cache + }) + + = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs + , inert_eq_tvs = eq_tvs + , inert_dicts = solved_dicts + , inert_irreds = solved_irreds + , inert_funeqs = solved_funeqs } + , inert_frozen = emptyCts -- All out + + -- At some point, I used to flush all the solved, in + -- fear of evidence loops. But I think we are safe, + -- flushing is why T3064 had become slower + , inert_solved = solved -- PredMap emptyTM + , inert_flat_cache = flat_cache -- FamHeadMap emptyTM + , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM + } + in (wanted, is_solved) + + where gd_eqs = filterVarEnv_Directly (\_ ct -> not (isWantedCt ct)) eqs + wanted_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ + eqs `minusVarEnv` gd_eqs + + (wanted_irreds, gd_irreds) = Bag.partitionBag isWantedCt irreds + (wanted_dicts, gd_dicts) = extractWantedCMap dicts + (wanted_funeqs, gd_funeqs) = partCtFamHeadMap isWantedCt funeqs + + -- Is this all necessary? + solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) gd_eqs + solved_irreds = Bag.filterBag isGivenCt gd_irreds + (_,solved_dicts) = extractUnsolvedCMap gd_dicts + (_,solved_funeqs) = partCtFamHeadMap (not . isGivenCt) gd_funeqs + + wanted = wanted_eqs `unionBags` wanted_irreds `unionBags` + wanted_dicts `unionBags` wanted_funeqs + + +getInertInsols :: InertSet -> Cts +-- Insolubles only +getInertInsols is = inert_frozen is + +getInertUnsolved :: InertSet -> Cts +-- Unsolved Wanted or Derived only +getInertUnsolved (IS { inert_cans = icans }) + = let unsolved_eqs = foldVarEnv add_if_not_given emptyCts (inert_eqs icans) + add_if_not_given ct cts + | isGivenCt ct = cts + | otherwise = cts `extendCts` ct + (unsolved_irreds,_) = Bag.partitionBag (not . isGivenCt) (inert_irreds icans) + (unsolved_dicts,_) = extractUnsolvedCMap (inert_dicts icans) + (unsolved_funeqs,_) = partCtFamHeadMap (not . isGivenCt) (inert_funeqs icans) + in unsolved_eqs `unionBags` unsolved_irreds `unionBags` + unsolved_dicts `unionBags` unsolved_funeqs diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 4417408100..914d463f1f 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -65,7 +65,7 @@ simplifyTop wanteds = do { ev_binds_var <- newTcEvBinds ; zonked_wanteds <- zonkWC wanteds - ; wc_first_go <- runTcSWithEvBinds ev_binds_var $ solveWanteds zonked_wanteds + ; wc_first_go <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds ; cts <- applyTyVarDefaulting wc_first_go -- See Note [Top-level Defaulting Plan] @@ -79,7 +79,7 @@ simplifyTop wanteds = do { traceTc "simpl_top_loop }" empty ; TcRnMonad.getTcEvBinds ev_binds_var } | otherwise - = do { wc_residual <- runTcSWithEvBinds ev_binds_var $ solveWanteds wc + = do { wc_residual <- solveWantedsWithEvBinds ev_binds_var wc ; let wc_flat_approximate = approximateWC wc_residual ; (dflt_eqs,_unused_bind) <- runTcS $ applyDefaultingRules wc_flat_approximate @@ -198,13 +198,17 @@ simplifyDeriv orig pred tvs theta ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] ; (residual_wanted, _ev_binds1) - <- runTcS $ solveWanteds (mkFlatWC wanted) + <- solveWanteds (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] get_good :: Ct -> Either PredType Ct - get_good ct | validDerivPred skol_set p = Left p - | otherwise = Right ct + get_good ct | validDerivPred skol_set p + , isWantedCt ct = Left p + -- NB: residual_wanted may contain unsolved + -- Derived and we stick them into the bad set + -- so that reportUnsolved may decide what to do with them + | otherwise = Right ct where p = ctPred ct -- We never want to defer these errors because they are errors in the @@ -363,8 +367,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- bindings, so we can't just revert to the input -- constraint. ; ev_binds_var <- newTcEvBinds - ; wanted_transformed <- runTcSWithEvBinds ev_binds_var $ - solveWanteds zonked_wanteds + ; wanted_transformed <- solveWantedsWithEvBinds ev_binds_var zonked_wanteds -- Step 3) Fail fast if there is an insoluble constraint, -- unless we are deferring errors to runtime @@ -376,12 +379,13 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds) -- NB: Already the fixpoint of any unifications that may have happened -- NB: We do not do any defaulting when inferring a type, this can lead -- to less polymorphic types, see Note [Default while Inferring] - + -- NB: quant_candidates here are wanted or derived, we filter the wanteds later, anyway + -- Step 5) Minimize the quantification candidates ; (quant_candidates_transformed, _extra_binds) - <- runTcS $ solveWanteds $ WC { wc_flat = quant_candidates - , wc_impl = emptyBag - , wc_insol = emptyBag } + <- solveWanteds $ WC { wc_flat = quant_candidates + , wc_impl = emptyBag + , wc_insol = emptyBag } -- Step 6) Final candidates for quantification ; let final_quant_candidates :: Bag PredType @@ -515,6 +519,7 @@ to check the original wanted. approximateWC :: WantedConstraints -> Cts +-- Postcondition: Wanted or Derived Cts approximateWC wc = float_wc emptyVarSet wc where float_wc :: TcTyVarSet -> WantedConstraints -> Cts @@ -529,7 +534,7 @@ approximateWC wc = float_wc emptyVarSet wc float_flat :: TcTyVarSet -> Ct -> Cts float_flat skols ct | tyVarsOfCt ct `disjointVarSet` skols - , isWantedCt ct = singleCt ct + = singleCt ct | otherwise = emptyCts do_bag :: (a -> Bag c) -> Bag a -> Bag c @@ -642,7 +647,7 @@ simplifyRule name lhs_wanted rhs_wanted -- We allow ourselves to unify environment -- variables: runTcS runs with NoUntouchables - ; (resid_wanted, _) <- runTcS (solveWanteds zonked_all) + ; (resid_wanted, _) <- solveWanteds zonked_all ; zonked_lhs <- zonkWC lhs_wanted @@ -696,7 +701,7 @@ simplifyCheck wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, eb1) <- runTcS (solveWanteds wanteds) + ; (unsolved, eb1) <- solveWanteds wanteds ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved @@ -748,37 +753,28 @@ and does not fail if -fwarn-type-errors is on, so that we can continue compilation. The errors are turned into warnings in `reportUnsolved`. \begin{code} -solveWanteds :: WantedConstraints -> TcS WantedConstraints --- Returns: residual constraints, plus evidence bindings --- NB: When we are called from TcM there are no inerts to pass down to TcS -solveWanteds wanted - = do { (_,wc_out) <- solve_wanteds wanted - ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } - -- Discard Derived - ; return wc_ret } - -solve_wanteds :: WantedConstraints - -> TcS (TvSubst, WantedConstraints) - -- NB: wc_flats may be wanted *or* derived now - -- Returns the flattening substitution as well in case we need to apply it + +solveWanteds :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind) +-- Return the evidence binds in the BagEvBinds result +solveWanteds wanted = runTcS $ solve_wanteds wanted + +solveWantedsWithEvBinds :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints +-- Side-effect the EvBindsVar argument to add new bindings from solving +solveWantedsWithEvBinds ev_binds_var wanted + = runTcSWithEvBinds ev_binds_var $ solve_wanteds wanted + + +solve_wanteds :: WantedConstraints -> TcS WantedConstraints +-- NB: wc_flats may be wanted /or/ derived now solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) = do { traceTcS "solveWanteds {" (ppr wanted) - -- Try the flat bit - -- Discard from insols all the derived/given constraints - -- because they will show up again when we try to solve - -- everything else. Solving them a second time is a bit - -- of a waste, but the code is simple, and the program is - -- wrong anyway! - - -- DV: why only keepWanted? We make sure that we never float out - -- whatever constraints can yield equalities, including class - -- constraints with functional dependencies and hence all the derived - -- that were potentially insoluble will be re-generated. - -- (It would not hurt though to just keep the wanted and the derived) - -- See Note [The HasEqualities Predicate] in Inst.lhs - + -- Try the flat bit, including insolubles. Solving insolubles a + -- second time round is a bit of a waste but the code is simple + -- and the program is wrong anyway. + -- Why keepWanted insols? See Note [KeepWanted in SolveWanteds] ; let all_flats = flats `unionBags` keepWanted insols + -- DV: Used to be 'keepWanted insols' but just insols is ; impls_from_flats <- solveInteractCts $ bagToList all_flats @@ -786,7 +782,9 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- out of one or more of the implications. ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats) - ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS + ; is <- getTcSInerts + ; let insoluble_flats = getInertInsols is + unsolved_flats = getInertUnsolved is ; bb <- getTcEvBindsMap ; tb <- getTcSTyBindsMap @@ -798,20 +796,17 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols , text "current tybinds =" <+> vcat (map ppr (varEnvElts tb)) ] - ; (subst, remaining_unsolved_flats) <- solveCTyFunEqs unsolved_flats - -- See Note [Solving Family Equations] - -- NB: remaining_flats has already had subst applied + ; let wc = WC { wc_flat = unsolved_flats + , wc_impl = unsolved_implics + , wc_insol = insoluble_flats } + ; traceTcS "solveWanteds finished with" $ - vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats - , text "subst =" <+> ppr subst - ] + vcat [ text "wc (unflattened) =" <+> ppr wc ] + + ; unFlattenWC wc } + - ; return $ - (subst, WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats - , wc_impl = mapBag (substImplication subst) unsolved_implics - , wc_insol = mapBag (substCt subst) insoluble_flats }) - } simpl_loop :: Int -> Bag Implication @@ -822,24 +817,24 @@ simpl_loop n implics | otherwise = do { (implic_eqs, unsolved_implics) <- solveNestedImplications implics - ; inerts <- getTcSInerts - ; let ((_,unsolved_flats),_) = extractUnsolved inerts - ; let improve_eqs = implic_eqs -- NB: improve_eqs used to contain defaulting equations HERE but -- defaulting now happens only at simplifyTop and not deep inside -- simpl_loop! See Note [Top-level Defaulting Plan] - + + ; unsolved_flats <- getTcSInerts >>= (return . getInertUnsolved) ; traceTcS "solveWanteds: simpl_loop end" $ vcat [ text "improve_eqs =" <+> ppr improve_eqs , text "unsolved_flats =" <+> ppr unsolved_flats , text "unsolved_implics =" <+> ppr unsolved_implics ] + ; if isEmptyBag improve_eqs then return unsolved_implics else do { impls_from_eqs <- solveInteractCts $ bagToList improve_eqs ; simpl_loop (n+1) (unsolved_implics `unionBags` impls_from_eqs)} } + solveNestedImplications :: Bag Implication -> TcS (Cts, Bag Implication) -- Precondition: the TcS inerts may contain unsolved flats which have @@ -849,19 +844,17 @@ solveNestedImplications implics = return (emptyBag, emptyBag) | otherwise = do { inerts <- getTcSInerts - ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts - - ; let ((_insoluble_flats, unsolved_flats),thinner_inerts) = extractUnsolved inerts + ; traceTcS "solveNestedImplications starting, inerts are:" $ ppr inerts + ; let (pushed_givens, thinner_inerts) = splitInertsForImplications inerts + ; traceTcS "solveNestedImplications starting, more info:" $ - vcat [ text "inerts = " <+> ppr inerts - , text "insoluble_flats = " <+> ppr _insoluble_flats - , text "unsolved_flats = " <+> ppr unsolved_flats + vcat [ text "original inerts = " <+> ppr inerts + , text "pushed_givens = " <+> ppr pushed_givens , text "thinner_inerts = " <+> ppr thinner_inerts ] ; (implic_eqs, unsolved_implics) <- doWithInert thinner_inerts $ - do { let pushed_givens = givens_from_wanteds unsolved_flats - tcs_untouchables + do { let tcs_untouchables = foldr (unionVarSet . tyVarsOfCt) emptyVarSet pushed_givens -- Typically pushed_givens is very small, consists -- only of unsolved equalities, so no inefficiency @@ -892,23 +885,6 @@ solveNestedImplications implics ; return (implic_eqs, unsolved_implics) } - where givens_from_wanteds = foldrBag get_wanted [] - get_wanted cc rest_givens - | pushable_wanted cc - = let fl = ctEvidence cc - gfl = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol - , ctev_evtm = EvId (ctev_evar fl) - , ctev_pred = ctev_pred fl } - this_given = cc { cc_ev = gfl } - in this_given : rest_givens - | otherwise = rest_givens - - pushable_wanted :: Ct -> Bool - pushable_wanted cc - | isWantedCt cc - = isEqPred (ctPred cc) -- see Note [Preparing inert set for implications] - | otherwise = False - solveImplication :: TcTyVarSet -- Untouchable TcS unification variables -> Implication -- Wanted -> TcS (Cts, -- All wanted or derived floated equalities: var = type @@ -934,19 +910,17 @@ solveImplication tcs_untouchables ; MASSERT (isEmptyBag impls_from_givens) -- Simplify the wanteds - ; (_flat_subst, - WC { wc_flat = unsolved_flats - , wc_impl = unsolved_implics - , wc_insol = insols }) <- solve_wanteds wanteds - -- NB: Not solveWanteds because we need the derived equalities, - -- which may not be solvable (due to touchability) in this implication - -- but may become solvable by spontantenous unification outside. + ; WC { wc_flat = unsolved_flats + , wc_impl = unsolved_implics + , wc_insol = insols } <- solve_wanteds wanteds ; let (res_flat_free, res_flat_bound) = floatEqualities skols givens unsolved_flats - final_flat = keepWanted res_flat_bound - ; let res_wanted = WC { wc_flat = final_flat + ; let res_wanted = WC { wc_flat = keepWanted $ res_flat_bound + -- I think this keepWanted must eventually go away, but it is + -- a real code-breaking change. + -- See Note [KeepWanted in SolveImplication] , wc_impl = unsolved_implics , wc_insol = insols } @@ -964,6 +938,82 @@ solveImplication tcs_untouchables ; return (res_flat_free, res_implic) } -- and we are back to the original inerts +\end{code} + +Note [KeepWanted in SolveWanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we have: + let all_flats = flats `unionBags` keepWanted insols +instead of the simpler: + let all_flats = flats `unionBags` insols +in solve_wanteds? + +Assume a top-level class and instance declaration: + + class D a b | a -> b + instance D [a] [a] + +Assume we have started with an implication: + + forall c. Eq c => { wc_flat = D [c] c [W] } + +which we have simplified to: + + forall c. Eq c => { wc_flat = D [c] c [W] + , wc_insols = (c ~ [c]) [D] } + +For some reason, e.g. because we floated an equality somewhere else, +we might try to re-solve this implication. If we do not do a +keepWanted, then we will end up trying to solve the following +constraints the second time: + + (D [c] c) [W] + (c ~ [c]) [D] + +which will result in two Deriveds to end up in the insoluble set: + + wc_flat = D [c] c [W] + wc_insols = (c ~ [c]) [D], (c ~ [c]) [D] + +which can result in reporting the same error twice. + +So, do we /lose/ some potentially useful information by doing this? + +No, because the insoluble Derived/Given are going to be equalities, +which are going to be derivable anyway from the rest of the flat +constraints. + + +Note [KeepWanted in SolveImplication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Here is a real example, +stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs + + class C a b | a -> b + g :: C a b => a -> b -> () + f :: C a b => a -> b -> () + f xa xb = + let loop = g xa + in loop xb + +We will first try to infer a type for loop, and we will succeed: + C a b' => b' -> () +Subsequently, we will type check (loop xb) and all is good. But, +recall that we have to solve a final implication constraint: + C a b => (C a b' => .... cts from body of loop .... )) +And now we have a problem as we will generate an equality b ~ b' and fail to +solve it. + +I actually think this is a legitimate behaviour (to fail). After all, if we had +given the inferred signature to foo we would have failed as well, but we have to +find a workaround because library code breaks. + +For now I keep the 'keepWanted' though it seems problematic e.g. we might discard +a useful Derived! + +\begin{code} + floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) -- Post: The returned FlavoredEvVar's are only Wanted or Derived @@ -1259,28 +1309,42 @@ and `?x :: Char` never exist in the same context, so they don't get to interact to cause failure. \begin{code} -solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts) --- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible --- See Note [Solving Family Equations] --- Returns: a bunch of unsolved constraints from the original Cts and implications --- where the newly generated equalities (alpha := F xi) have been substituted through. -solveCTyFunEqs cts - = do { untch <- getUntouchables - ; let (unsolved_can_cts, (ni_subst, cv_binds)) - = getSolvableCTyFunEqs untch cts - ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:" - , ppr ni_subst, ppr cv_binds - ]) - ; mapM_ solve_one cv_binds - - ; return (niFixTvSubst ni_subst, unsolved_can_cts) } - where - solve_one (Wanted { ctev_evar = cv }, tv, ty) - = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) - solve_one (Derived {}, tv, ty) - = setWantedTyBind tv ty - solve_one arg - = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg + + +unFlattenWC :: WantedConstraints -> TcS WantedConstraints +unFlattenWC wc + = do { (subst, remaining_unsolved_flats) <- solveCTyFunEqs (wc_flat wc) + -- See Note [Solving Family Equations] + -- NB: remaining_flats has already had subst applied + ; return $ + WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats + , wc_impl = mapBag (substImplication subst) (wc_impl wc) + , wc_insol = mapBag (substCt subst) (wc_insol wc) } + } + where + solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts) + -- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible + -- See Note [Solving Family Equations] + -- Returns: a bunch of unsolved constraints from the original Cts and implications + -- where the newly generated equalities (alpha := F xi) have been substituted through. + solveCTyFunEqs cts + = do { untch <- getUntouchables + ; let (unsolved_can_cts, (ni_subst, cv_binds)) + = getSolvableCTyFunEqs untch cts + ; traceTcS "defaultCTyFunEqs" (vcat [text "Trying to default family equations:" + , ppr ni_subst, ppr cv_binds + ]) + ; mapM_ solve_one cv_binds + + ; return (niFixTvSubst ni_subst, unsolved_can_cts) } + where + solve_one (Wanted { ctev_evar = cv }, tv, ty) + = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) + solve_one (Derived {}, tv, ty) + = setWantedTyBind tv ty + solve_one arg + = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg + ------------ type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)]) -- The TvSubstEnv is not idempotent, but is loop-free @@ -1355,10 +1419,10 @@ When is it ok to do so? * * ********************************************************************************* \begin{code} -applyDefaultingRules :: Cts -- All wanteds - -> TcS Cts -- All wanteds again! --- Return some *extra* givens, which express the --- type-class-default choice +applyDefaultingRules :: Cts -- Wanteds or Deriveds + -> TcS Cts -- Derived equalities +-- Return some extra derived equalities, which express the +-- type-class default choice. applyDefaultingRules wanteds | isEmptyBag wanteds = return emptyBag @@ -1441,7 +1505,7 @@ defaultTyVar the_tv ; implics_from_defaulting <- solveInteractCts cts ; MASSERT (isEmptyBag implics_from_defaulting) - ; (_,unsolved) <- extractUnsolvedTcS + ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) ; if isEmptyBag (keepWanted unsolved) then return (listToBag cts) else return emptyBag } | otherwise = return emptyBag -- The common case @@ -1485,7 +1549,7 @@ default is default_k we do not simply generate [D] (k ~ default_k) because: findDefaultableGroups :: ( [Type] , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> Cts -- Unsolved + -> Cts -- Unsolved (wanted or derived) -> [[(Ct,TcTyVar)]] findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | null default_tys = [] @@ -1557,7 +1621,7 @@ disambigGroup (default_ty:default_tys) group -- I am not certain if any implications can be generated -- but I am letting this fail aggressively if this ever happens. - ; (_,unsolved) <- extractUnsolvedTcS + ; unsolved <- getTcSInerts >>= (return . getInertUnsolved) ; traceTcS "disambigGroup (solving) }" $ text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved) ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6d48c20287..5784788970 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -147,7 +147,11 @@ tcTyClGroup boot_details tyclds -- expects well-formed TyCons ; tcExtendGlobalEnv tyclss $ do { traceTc "Starting validity check" (ppr tyclss) - ; mapM_ (addLocM checkValidTyCl) (flattenTyClDecls tyclds) + ; mapM_ (recoverM (return ()) . addLocM checkValidTyCl) + (flattenTyClDecls tyclds) + -- We recover, which allows us to report multiple validity errors + -- even from successive groups. But we stop after all groups are + -- processed if we find any errors. -- Step 4: Add the implicit things; -- we want them in the environment because diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index abc172e1c9..ba397a0568 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -38,7 +38,6 @@ module Outputable ( colBinder, bold, keyword, -- * Converting 'SDoc' into strings and outputing it - hPrintDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, showSDoc, showSDocOneLine, @@ -91,7 +90,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set import Data.Word -import System.IO ( Handle, hFlush ) +import System.IO ( Handle ) import System.FilePath @@ -330,13 +329,6 @@ ifPprDebug d = SDoc $ \ctx -> \end{code} \begin{code} -hPrintDump :: DynFlags -> Handle -> SDoc -> IO () -hPrintDump dflags h doc = do - Pretty.printDoc PageMode (pprCols dflags) h - (runSDoc better_doc (initSDocContext dflags defaultDumpStyle)) - hFlush h - where - better_doc = doc $$ blankLine printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () printForUser dflags handle unqual doc diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index bb7ae45ba8..7cbeeab551 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1122,6 +1122,18 @@ <entry><option>-XNoPackageImports</option></entry> </row> <row> + <entry><option>-XLambdaCase</option></entry> + <entry>Enable <link linkend="lambda-case">lambda-case expressions</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoLambdaCase</option></entry> + </row> + <row> + <entry><option>-XMultiWayIf</option></entry> + <entry>Enable <link linkend="multi-way-if">multi-way if-expressions</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoMultiWayIf</option></entry> + </row> + <row> <entry><option>-XSafe</option></entry> <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry> <entry>dynamic</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index df1ff2c181..dde235eda4 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1669,6 +1669,48 @@ continues to stand for the unboxed singleton tuple data constructor. </sect2> +<sect2 id="lambda-case"> +<title>Lambda-case</title> +<para> +The <option>-XLambdaCase</option> flag enables expressions of the form +<programlisting> + \case { p1 -> e1; ...; pN -> eN } +</programlisting> +which is equivalent to +<programlisting> + \freshName -> case freshName of { p1 -> e1; ...; pN -> eN } +</programlisting> +Note that <literal>\case</literal> starts a layout, so you can write +<programlisting> + \case + p1 -> e1 + ... + pN -> eN +</programlisting> +</para> +</sect2> + +<sect2 id="multi-way-if"> +<title>Multi-way if-expressions</title> +<para> +With <option>-XMultiWayIf</option> flag GHC accepts conditional expressions +with multiple branches: +<programlisting> + if | guard1 -> expr1 + | ... + | guardN -> exprN +</programlisting> +which is roughly equivalent to +<programlisting> + case () of + _ | guard1 -> expr1 + ... + _ | guardN -> exprN +</programlisting> +except that multi-way if-expressions do not alter the layout. +</para> +</sect2> + <sect2 id="disambiguate-fields"> <title>Record field disambiguation</title> <para> @@ -402,13 +402,13 @@ $(eval $(call addPackage,array)) $(eval $(call addPackage,deepseq)) $(eval $(call addPackage,bytestring)) $(eval $(call addPackage,containers)) +$(eval $(call addPackage,old-locale)) +$(eval $(call addPackage,old-time)) +$(eval $(call addPackage,time)) $(eval $(call addPackage,Win32,($$(Windows),YES))) $(eval $(call addPackage,unix,($$(Windows),NO))) -$(eval $(call addPackage,old-locale)) -$(eval $(call addPackage,old-time)) -$(eval $(call addPackage,time)) $(eval $(call addPackage,directory)) $(eval $(call addPackage,process)) $(eval $(call addPackage,haskell98)) diff --git a/ghc/ghc-cross.wrapper b/ghc/ghc-cross.wrapper new file mode 100644 index 0000000000..56564e589d --- /dev/null +++ b/ghc/ghc-cross.wrapper @@ -0,0 +1 @@ +exec "$executablename" -B"$topdir" ${1+"$@"} -pgma "$pgmgcc" -pgmc "$pgmgcc" -pgml "$pgmgcc" diff --git a/includes/Cmm.h b/includes/Cmm.h index bfac1ee2f0..1788122f29 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The University of Glasgow 2004 + * (c) The University of Glasgow 2004-2012 * * This file is included at the top of all .cmm source files (and * *only* .cmm files). It defines a collection of useful macros for @@ -50,7 +50,7 @@ * StgTSO_what_next(CurrentTSO) = x * * where the StgTSO_what_next() macro is automatically generated by - * mkDerivedConstnants.c. If you need to access a field that doesn't + * mkDerivedConstants.c. If you need to access a field that doesn't * already have a macro, edit that file (it's pretty self-explanatory). * * -------------------------------------------------------------------------- */ diff --git a/includes/mkDerivedConstants.cross.awk b/includes/mkDerivedConstants.cross.awk new file mode 100644 index 0000000000..c66655e922 --- /dev/null +++ b/includes/mkDerivedConstants.cross.awk @@ -0,0 +1,350 @@ +## This script rewrites normal C structs into successively +## greater ones so that field offset computation becomes a +## sizeof lookup and thus amenable to compile-time computations. + +## Usage: pipe stg/Regs.h into 'awk' running this script +## to obtain a .c file that can be compiled to .o +## with the gcc from the cross toolchain. Then +## use another 'awk' script to process the 'nm' +## output of the object file. + +## Motivation: since in general we can not run executables +## created by the cross toolchain, we need another +## way of finding out field offsets and type sizes +## of the target platform. + +BEGIN { + interesting = 0 + seed = 0 + print "/* this file is generated by mkDerivedConstants.cross.awk, do not touch */" + print "/* needs to be compiled with the target gcc */" + print "" + print "#include \"Rts.h\"" + print "#include \"Capability.h\"" + print "" + ## these do not have a proper typedef; supply them here + print "#define FLAG_STRUCT_TYPE(IT) typedef struct IT ## _FLAGS IT ## _FLAGS" + print "FLAG_STRUCT_TYPE(GC);" + print "FLAG_STRUCT_TYPE(DEBUG);" + print "FLAG_STRUCT_TYPE(COST_CENTRE);" + print "FLAG_STRUCT_TYPE(PROFILING);" + print "FLAG_STRUCT_TYPE(TRACE);" + print "FLAG_STRUCT_TYPE(CONCURRENT);" + print "FLAG_STRUCT_TYPE(MISC);" + print "FLAG_STRUCT_TYPE(PAR);" + print "FLAG_STRUCT_TYPE(TICKY);" + ## these we do know how to get the field size, + ## so do not bother mining it + print "#define DO_NOT_MINE_UNION_MEMBER(STRUCT, NESTED_MEMBER, ID) char nestedfieldsize$ ## STRUCT ## $ ## ID [sizeof ((STRUCT*)0)->NESTED_MEMBER]" + print "DO_NOT_MINE_UNION_MEMBER(StgHeader, prof.hp.ldvw, prof_hp_ldvw);" + print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraFwd, b.bitmap, b_bitmap);" + print "DO_NOT_MINE_UNION_MEMBER(StgFunInfoExtraRev, b.bitmap, b_bitmap);" +} + +## pass through embedded unions +eat_union && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ { + sub(/^[ \t]*}[ \t]*/, "") + sub(/[ \t]*;[ \t]*$/, "") + new_offset_struct_name = struct_name $0 + print "" + + eat_union = 0 + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $0 ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $0 ") ? 1 : -1];" + } + + offset_struct_name = new_offset_struct_name + next +} + +eat_union { + next +} + +/# [0-9]* "rts\// { + ours = 1 + next +} + +/# [0-9]* "includes\// { + ours = 1 + next +} + +## filter out non-ghc headers +/# [0-9]* "/ { + ours = 0 + next +} + +!ours { + next +} + +!interesting { + struct_name = "$" seed "$" + offset_struct_name = "" + known_struct_name = "" + eat_union = 0 + assumptions = "" +} + +## kill empty line +/^[ \t]*$/ { + next +} + +/^# [0-9]/ { + print + next +} + +/^typedef struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ { + if (interesting) error "previous struct not closed?" + interesting = 1 + print "" + print "/* ### Creating offset structs for " $3 " ### */" + next +} + +/^struct[ \t][ \t]*[_0-9a-zA-Z]*[ \t]*{[ \t]*$/ { + if (interesting) error "previous struct not closed?" + interesting = 1 + known_struct_name = $2 + sub(/_$/, "", known_struct_name); + print "" + print "/* ### Creating offset structs for " known_struct_name " ### */" + print "char associate$" known_struct_name "$" seed ";" + next +} + +## end of struct +## +interesting && /^[ \t]*}[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/{ + sub(/;$/, "", $2) + + print "char associate$" $2 "$" seed ";" + print "char SIZEOF$" seed "[sizeof(" $2 ")];" + print "" + print "" + gsub(/\^\^\^/, $2, assumptions); + print assumptions + ++seed + interesting = 0 + next +} + +## Ptr-typedef +interesting && /^[ \t]*}[ \t]*\*[_0-9a-zA-Z][_0-9a-zA-Z]*Ptr[ \t]*;[ \t]*$/{ + sub(/Ptr;$/, "", $2) + sub(/^\*/, "", $2) + + print "char associate$" $2 "$" seed ";" + print "char SIZEOF$" seed "[sizeof(" $2 ")];" + print "" + print "" + gsub(/\^\^\^/, $2, assumptions); + print assumptions + ++seed + interesting = 0 + next +} + +interesting && /^[ \t]*}[; \t]*$/ { + print "char SIZEOF$" seed "[sizeof(" known_struct_name ")];" + print "" + print "" + gsub(/\^\^\^/, known_struct_name, assumptions); + print assumptions + ++seed + interesting = 0 +} + +# collapse whitespace after '*' +interesting { + # normalize some types + sub(/struct StgClosure_[ \t]*\*/, "StgClosure *") + gsub(/\*[ \t]*volatile/, "*") + # group stars together + gsub(/\*[ \t]*/, "*") + sub(/\*/, " *") + print "// " $0 + # remove volatile + sub(/[ \t]volatile[ \t]/, " ") + # remove const + sub(/[ \t]const[ \t]/, " ") +} + +## (pointer to struct) member of struct +## +interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*\*[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ { + if (!$4) { + sub(/^\*/, "", $3) + $4 = $3 + } + sub(/;$/, "", $4) + + new_offset_struct_name = struct_name $4 + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $4 ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $4 ") ? 1 : -1];" + } + print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 "*)];" + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + +## (simple pointer) member of struct +## +interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\*\**[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t]*;[ \t]*$/ { + sub(/;$/, "", $2) + sub(/^\**/, "", $2) + + new_offset_struct_name = struct_name $2 + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];" + } + print "char fieldsize" new_offset_struct_name "[sizeof(" $1 "*)];" + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + +## member of struct +## +interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ { + sub(/;$/, "", $2) + + new_offset_struct_name = struct_name $2 + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $2 ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $2 ") ? 1 : -1];" + } + print "char fieldsize" new_offset_struct_name "[sizeof(" $1 ")];" + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + +## struct member of struct +## +interesting && /^[ \t]*struct[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*$/ { + sub(/;$/, "", $3) + + new_offset_struct_name = struct_name $3 + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " $3 ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " $3 ") ? 1 : -1];" + } + print "char fieldsize" new_offset_struct_name "[sizeof(struct " $2 ")];" + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + +## embedded union +interesting && /^[ \t]*union[ \t]*{[ \t]*$/ { + eat_union = 1 + next +} + +## array member +interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*\**[_0-9a-zA-Z][_0-9a-zA-Z]*\[.*\];[ \t]*$/ { + sub(/;[ \t]*$/, "", $0) + + full = $0 + sub(/^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*/, "", full) + split(full, parts, "[") + mname = parts[1] + sub(/^\**/, "", mname) + + new_offset_struct_name = struct_name mname + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];" + } + + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + + +## padded member of struct +## of this form: StgHalfInt slow_apply_offset; StgHalfWord __pad_slow_apply_offset;; +## +interesting && /^[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*;[ \t]*[_0-9a-zA-Z][_0-9a-zA-Z]*[ \t][ \t]*__pad_[a-zA-Z][_0-9a-zA-Z]*;;*[ \t]*$/ { + mname = $2 + sub(/;$/, "", mname) + + new_offset_struct_name = struct_name mname + print "" + + if (!offset_struct_name) + { + print "char starting" new_offset_struct_name "[2];" + } + else + { + assumptions = assumptions "\n" "char sizeof" new_offset_struct_name "[offsetof(^^^, " mname ")];" + assumptions = assumptions "\n" "typedef char verify_size" new_offset_struct_name "[sizeof sizeof" new_offset_struct_name " == offsetof(^^^, " mname ") ? 1 : -1];" + } + print "" + print "" + offset_struct_name = new_offset_struct_name + next +} + +interesting && /;[ \t]*$/ { + print "Member not recognized: " $0 > "/dev/stderr" + exit 1 +}
\ No newline at end of file diff --git a/includes/mkSizeMacros.cross.awk b/includes/mkSizeMacros.cross.awk new file mode 100644 index 0000000000..e33e4ff4e5 --- /dev/null +++ b/includes/mkSizeMacros.cross.awk @@ -0,0 +1,82 @@ +BEGIN { + print "#define OFFSET(s_type, field) OFFSET_ ## s_type ## _ ## field" + print "#define FIELD_SIZE(s_type, field) FIELD_SIZE_ ## s_type ## _ ## field" + print "#define TYPE_SIZE(type) TYPE_SIZE_ ## type" + print "" +} + +/^0[0-9a-zA-Z]* C _*associate\$/ { + sub(/_*associate\$/, "", $3) + split($3, arr, "$") + assoc[arr[2]] = arr[1] + next +} + +/^00*2 C _*starting\$[0-9]*\$[_0-9a-zA-Z]*$/ { + sub(/_*starting\$/, "", $3) + split($3, arr, "$") + sub(/^0*/, "", $1) + print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x0" + next +} + +/^0[0-9a-zA-Z]* C _*sizeof\$[0-9]*\$[_0-9a-zA-Z]*$/ { + sub(/_*sizeof\$/, "", $3) + split($3, arr, "$") + sub(/^0*/, "", $1) + print "#define OFFSET_" assoc[arr[1]] "_" arr[2] " 0x" $1 + next +} + +/^0[0-9a-zA-Z]* C _*fieldsize\$[0-9]*\$[_0-9a-zA-Z]*$/ { + sub(/_*fieldsize\$/, "", $3) + split($3, arr, "$") + sub(/^0*/, "", $1) + print "#define FIELD_SIZE_" assoc[arr[1]] "_" arr[2] " 0x" $1 "UL" + next +} + +/^0[0-9a-zA-Z]* C _*nestedfieldsize\$[_0-9a-zA-Z]*\$[_0-9a-zA-Z]*$/ { + sub(/_*nestedfieldsize\$/, "", $3) + split($3, arr, "$") + sub(/^0*/, "", $1) + print "#define FIELD_SIZE_" arr[1] "_" arr[2] " 0x" $1 "UL" + next +} + +/^0[0-9a-zA-Z]* C _*SIZEOF\$[0-9]*$/ { + sub(/_*SIZEOF\$/, "", $3) + sub(/^0*/, "", $1) + print "#define TYPE_SIZE_" assoc[$3] " 0x" $1 + next +} + +{ print "// " $0 } + +END { + ## some indirect offsets + print "#define OFFSET_StgHeader_prof_ccs (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_ccs)" + print "#define OFFSET_StgHeader_prof_hp_ldvw (OFFSET_StgHeader_prof + OFFSET_StgProfHeader_hp + 0)" + print "#define OFFSET_StgTSO_prof_cccs (OFFSET_StgTSO_prof + OFFSET_StgTSOProfInfo_cccs)" + print "#define OFFSET_RTS_FLAGS_ProfFlags_showCCSOnException (OFFSET_RTS_FLAGS_ProfFlags + OFFSET_PROFILING_FLAGS_showCCSOnException)" + + + print "#define OFFSET_RTS_FLAGS_DebugFlags_apply (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_apply)" + print "#define OFFSET_RTS_FLAGS_DebugFlags_sanity (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_sanity)" + print "#define OFFSET_RTS_FLAGS_DebugFlags_weak (OFFSET_RTS_FLAGS_DebugFlags + OFFSET_DEBUG_FLAGS_weak)" + print "#define OFFSET_RTS_FLAGS_GcFlags_initialStkSize (OFFSET_RTS_FLAGS_GcFlags + OFFSET_GC_FLAGS_initialStkSize)" + print "#define OFFSET_RTS_FLAGS_MiscFlags_tickInterval (OFFSET_RTS_FLAGS_MiscFlags + OFFSET_MISC_FLAGS_tickInterval)" + + print "#define OFFSET_StgFunInfoExtraFwd_b_bitmap (OFFSET_StgFunInfoExtraFwd_b + 0)" + print "#define OFFSET_StgFunInfoExtraRev_b_bitmap (OFFSET_StgFunInfoExtraRev_b + 0)" + + ## some indirect field sizes + print "#define FIELD_SIZE_StgHeader_prof_ccs FIELD_SIZE_StgProfHeader_ccs" + print "#define FIELD_SIZE_StgTSO_prof_cccs FIELD_SIZE_StgTSOProfInfo_cccs" + print "#define FIELD_SIZE_RTS_FLAGS_ProfFlags_showCCSOnException FIELD_SIZE_PROFILING_FLAGS_showCCSOnException" + print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_apply FIELD_SIZE_DEBUG_FLAGS_apply" + print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_sanity FIELD_SIZE_DEBUG_FLAGS_sanity" + print "#define FIELD_SIZE_RTS_FLAGS_DebugFlags_weak FIELD_SIZE_DEBUG_FLAGS_weak" + print "#define FIELD_SIZE_RTS_FLAGS_GcFlags_initialStkSize FIELD_SIZE_GC_FLAGS_initialStkSize" + print "#define FIELD_SIZE_RTS_FLAGS_MiscFlags_tickInterval FIELD_SIZE_MISC_FLAGS_tickInterval" +} diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h index 2492bb3bc1..e6c746b4bc 100644 --- a/includes/rts/prof/CCS.h +++ b/includes/rts/prof/CCS.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 2009 + * (c) The GHC Team, 2009-2012 * * Macros for profiling operations in STG code * @@ -107,7 +107,7 @@ typedef struct IndexTable_ { CostCentre *cc; CostCentreStack *ccs; struct IndexTable_ *next; - unsigned int back_edge; + nat back_edge; } IndexTable; diff --git a/includes/stg/Regs.h b/includes/stg/Regs.h index bfc3d4b04d..bf17b7e825 100644 --- a/includes/stg/Regs.h +++ b/includes/stg/Regs.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1998-2009 + * (c) The GHC Team, 1998-2012 * * Registers in the STG machine. * @@ -21,7 +21,7 @@ * * The register set is backed by a table in memory (struct * StgRegTable). If a particular STG register is not mapped to a - * machine register, then the apprpriate slot in this table is used + * machine register, then the appropriate slot in this table is used * instead. * * This table is itself pointed to by another register, BaseReg. If @@ -58,7 +58,7 @@ typedef union { * register, probably because there's a shortage of real registers. * 2) caller-saves registers are saved across a CCall */ -typedef struct StgRegTable_ { +typedef struct { StgUnion rR1; StgUnion rR2; StgUnion rR3; @@ -80,13 +80,13 @@ typedef struct StgRegTable_ { StgPtr rSpLim; StgPtr rHp; StgPtr rHpLim; - struct CostCentreStack_ * rCCCS; // current cost-centre-stack + struct CostCentreStack_ * rCCCS; /* current cost-centre-stack */ struct StgTSO_ * rCurrentTSO; struct nursery_ * rNursery; struct bdescr_ * rCurrentNursery; /* Hp/HpLim point into this block */ struct bdescr_ * rCurrentAlloc; /* for allocation using allocate() */ StgWord rHpAlloc; /* number of *bytes* being allocated in heap */ - StgWord rRet; // holds the return code of the thread + StgWord rRet; /* holds the return code of the thread */ } StgRegTable; #if IN_STG_CODE diff --git a/libraries/bin-package-db/bin-package-db.cabal b/libraries/bin-package-db/bin-package-db.cabal index 6a40de0255..ce023d4c57 100644 --- a/libraries/bin-package-db/bin-package-db.cabal +++ b/libraries/bin-package-db/bin-package-db.cabal @@ -25,7 +25,7 @@ Library { build-depends: base >= 4 && < 5 build-depends: binary == 0.5.*, - Cabal >= 1.8 && < 1.16 + Cabal >= 1.8 && < 1.18 extensions: CPP } diff --git a/libraries/tarballs/time-1.4.0.1.tar.gz b/libraries/tarballs/time-1.4.0.1.tar.gz Binary files differnew file mode 100644 index 0000000000..04181df24b --- /dev/null +++ b/libraries/tarballs/time-1.4.0.1.tar.gz diff --git a/libraries/tarballs/time-1.4.tar.gz b/libraries/tarballs/time-1.4.tar.gz Binary files differdeleted file mode 100644 index a7044565d3..0000000000 --- a/libraries/tarballs/time-1.4.tar.gz +++ /dev/null diff --git a/rules/cross-compiling.mk b/rules/cross-compiling.mk new file mode 100644 index 0000000000..9f9ec6f542 --- /dev/null +++ b/rules/cross-compiling.mk @@ -0,0 +1,24 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2012 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +define cross-compiling # $1 = then, $2 = else, $3 = then, ... +ifneq "$(TARGETPLATFORM)" "$(HOSTPLATFORM)" +ifneq "$(BUILDPLATFORM)" "$(HOSTPLATFORM)" +$(warning When cross-compiling, the build and host platforms must be equal (--build=$(BUILDPLATFORM) --host=$(HOSTPLATFORM) --target=$(TARGETPLATFORM))) +endif +$1 +$3 +else +$2 +$4 +endif +endef diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index d00324f173..e39f42ec5f 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -1,6 +1,6 @@ {-# OPTIONS -cpp -fglasgow-exts #-} {-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. +-- The above warning suppression 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 @@ -179,7 +179,7 @@ mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi mkTagStmt tag = text ("R1 = R1 + "++ show tag) genMkPAP regstatus macro jump ticker disamb - no_load_regs -- don't load argumnet regs before jumping + no_load_regs -- don't load argument regs before jumping args_in_regs -- arguments are already in regs is_pap args all_args_size fun_info_label is_fun_case @@ -223,7 +223,7 @@ genMkPAP regstatus macro jump ticker disamb else shuffle_extra_args, -- for a PAP, we have to arrange that the stack contains a - -- return address in the even that stg_PAP_entry fails its + -- return address in the event that stg_PAP_entry fails its -- heap check. See stg_PAP_entry in Apply.hc for details. if is_pap then text "R2 = " <> mkApplyInfoName this_call_args <> semi diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index 7bbab037e4..ce15310292 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -16,7 +16,7 @@ Executable ghc-cabal Main-Is: ghc-cabal.hs Build-Depends: base >= 3 && < 5, - Cabal >= 1.10 && < 1.16, + Cabal >= 1.10 && < 1.18, directory >= 1.1 && < 1.2, filepath >= 1.2 && < 1.4 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index ddc4821a07..d992b5405f 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -137,6 +137,8 @@ flags = [ "location of the global package database", Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) "never read the user package database", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database (DEPRECATED)", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index dff6012cb0..bd297828e5 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -13,6 +13,7 @@ import HpcFlags import HpcUtils import System.Directory +import System.IO (localeEncoding) import Data.List import Data.Maybe(fromJust) import Data.Array @@ -79,6 +80,8 @@ markup_main flags (prog:modNames) = do writeFileUsing (dest_dir ++ "/" ++ filename ++ ".html") $ "<html>" ++ + "<head>" ++ + charEncodingTag ++ "<style type=\"text/css\">" ++ "table.bar { background-color: #f25913; }\n" ++ "td.bar { background-color: #60de51; }\n" ++ @@ -87,6 +90,8 @@ markup_main flags (prog:modNames) = do ".dashboard td { border: solid 1px black }\n" ++ ".dashboard th { border: solid 1px black }\n" ++ "</style>\n" ++ + "</head>" ++ + "<body>" ++ "<table class=\"dashboard\" width=\"100%\" border=1>\n" ++ "<tr>" ++ "<th rowspan=2><a href=\"" ++ index_name ++ ".html\">module</a></th>" ++ @@ -110,7 +115,7 @@ markup_main flags (prog:modNames) = do [ modSummary | (_,_,modSummary) <- mods' ]) - ++ "</table></html>\n" + ++ "</table></body></html>\n" writeSummary index_name $ \ (n1,_,_) (n2,_,_) -> compare n1 n2 @@ -130,6 +135,11 @@ markup_main flags (prog:modNames) = do markup_main _ [] = hpcError markup_plugin $ "no .tix file or executable name specified" +charEncodingTag :: String +charEncodingTag = + "<meta http-equiv=\"Content-Type\" " ++ + "content=\"text/html; " ++ "charset=" ++ show localeEncoding ++ "\">" + genHtmlFromMod :: String -> Flags @@ -206,7 +216,10 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do let fileName = modName0 ++ ".hs.html" putStrLn $ "Writing: " ++ fileName writeFileUsing (dest_dir ++ "/" ++ fileName) $ - unlines [ "<html><style type=\"text/css\">", + unlines ["<html>", + "<head>", + charEncodingTag, + "<style type=\"text/css\">", "span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px }", if invertOutput then "span.nottickedoff { color: #404040; background: white; font-style: oblique }" @@ -222,7 +235,10 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do else "span.decl { font-weight: bold }", "span.spaces { background: white }", "</style>", - "<pre>"] ++ addLines content' ++ "\n</pre>\n</html>\n"; + "</head>", + "<body>", + "<pre>"] ++ addLines content' ++ "\n</pre>\n</body>\n</html>\n"; + modSummary `seq` return (modName0,fileName,modSummary) diff --git a/utils/hpc/hpc-bin.cabal b/utils/hpc/hpc-bin.cabal index cd66853e5e..c9afba58f1 100644 --- a/utils/hpc/hpc-bin.cabal +++ b/utils/hpc/hpc-bin.cabal @@ -31,9 +31,9 @@ Executable hpc Build-Depends: base < 3 if flag(base3) || flag(base4) - Build-Depends: directory >= 1 && < 1.1, - containers >= 0.1 && < 0.3, - array >= 0.1 && < 0.3 + Build-Depends: directory >= 1 && < 1.2, + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5 Build-Depends: haskell98, hpc Extensions: CPP |