diff options
Diffstat (limited to 'compiler')
47 files changed, 632 insertions, 274 deletions
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 02eb0678ee..6941dd9c55 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -70,7 +70,7 @@ module Name ( NamedThing(..), getSrcLoc, getSrcSpan, getOccString, getOccFS, - pprInfixName, pprPrefixName, pprModulePrefix, + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, nameStableString, -- Re-export the OccName stuff @@ -535,6 +535,10 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 9f832731b1..50d48afb38 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,5 +1,5 @@ -- Cmm representations using Hoopl's Graph CmmNode e x. -{-# LANGUAGE CPP, GADTs #-} +{-# LANGUAGE GADTs #-} module Cmm ( -- * Cmm top-level datatypes diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs index fce8f7dae8..c91d553c47 100644 --- a/compiler/cmm/CmmCommonBlockElim.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -64,7 +64,9 @@ elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks g = replaceLabels env $ copyTicks env g where env = iterate mapEmpty blocks_with_key - groups = groupByInt hash_block (postorderDfs g) + -- The order of blocks doesn't matter here, but revPostorder also drops any + -- unreachable blocks, which is useful. + groups = groupByInt hash_block (revPostorder g) blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] -- Invariant: The blocks in the list are pairwise distinct diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index da365cfe7f..9f091da8c2 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -174,10 +174,9 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } | otherwise = (entry_id, shortcut_map) - -- blocks is a list of blocks in DFS postorder, while blockmap is - -- a map of blocks. We process each element from blocks and update - -- blockmap accordingly - blocks = postorderDfs g + -- blocks are sorted in reverse postorder, but we want to go from the exit + -- towards beginning, so we use foldr below. + blocks = revPostorder g blockmap = foldl' (flip addBlock) emptyBody blocks -- Accumulator contains three components: @@ -435,7 +434,7 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g) | otherwise = env used_blocks :: [CmmBlock] - used_blocks = postorderDfs g + used_blocks = revPostorder g used_lbls :: LabelSet used_lbls = setFromList $ map entryLabel used_blocks diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index bae5a739ca..946e146f9e 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 3f1633404c..d2525d1ffd 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -244,7 +244,7 @@ cmmLayoutStack dflags procpoints entry_args -- We need liveness info. Dead assignments are removed later -- by the sinking pass. let liveness = cmmLocalLiveness dflags graph - blocks = postorderDfs graph + blocks = revPostorder graph (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 6b4d792122..e837d29783 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -422,14 +422,6 @@ That's what the constant-folding operations on comparison operators do above. -- ----------------------------------------------------------------------------- -- Utils -isLit :: CmmExpr -> Bool -isLit (CmmLit _) = True -isLit _ = False - -isComparisonExpr :: CmmExpr -> Bool -isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op -isComparisonExpr _ = False - isPicReg :: CmmExpr -> Bool isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True isPicReg _ = False diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index eeae96083a..bef8f384b8 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -190,7 +190,7 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points minimalProcPointSet platform callProcPoints g - = extendPPSet platform g (postorderDfs g) callProcPoints + = extendPPSet platform g (revPostorder g) callProcPoints extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet @@ -242,11 +242,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach - let addBlock + let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock) - addBlock graphEnv b = + add_block graphEnv b = case mapLookup bid procMap of Just ProcPoint -> add graphEnv bid bid b Just (ReachedBy set) -> @@ -265,7 +265,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap regSetToList $ expectJust "ppLiveness" $ mapLookup pp liveness - graphEnv <- return $ foldlGraphBlocks addBlock mapEmpty g + graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g -- Build a map from proc point BlockId to pairs of: -- * Labels for their new procedures @@ -330,7 +330,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- replace branches to procpoints with branches to jumps blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' -- add the jump blocks to the graph - blockEnv''' = foldl' (flip insertBlock) blockEnv'' jumpBlocks + blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks let g' = ofBlockMap ppId blockEnv''' -- pprTrace "g' pre jumps" (ppr g') $ do return (mapInsert ppId g' newGraphEnv) @@ -374,8 +374,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- reversed later. let (_, block_order) = foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) - (postorderDfs g) - add_block_num (!i, !map) block = + (revPostorder g) + add_block_num (i, map) block = (i + 1, mapInsert (entryLabel block) i map) sort_fn (bid, _) (bid', _) = compare (expectJust "block_order" $ mapLookup bid block_order) diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 487f0bc244..43444639e1 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -173,7 +173,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks liveness = cmmLocalLiveness dflags graph getLive l = mapFindWithDefault Set.empty l liveness - blocks = postorderDfs graph + blocks = revPostorder graph join_pts = findJoinPoints blocks @@ -458,17 +458,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs occurs_once = not l_live && l_usages == Just 1 occurs_none = not l_live && l_usages == Nothing - inl_node = case mapExpDeep inl_exp node of - -- See Note [Improving conditionals] - CmmCondBranch (CmmMachOp (MO_Ne w) args) - ti fi l - -> CmmCondBranch (cmmMachOpFold dflags (MO_Eq w) args) - fi ti (inv_likeliness l) - node' -> node' - - inv_likeliness :: Maybe Bool -> Maybe Bool - inv_likeliness Nothing = Nothing - inv_likeliness (Just l) = Just (not l) + inl_node = improveConditional (mapExpDeep inl_exp node) inl_exp :: CmmExpr -> CmmExpr -- inl_exp is where the inlining actually takes place! @@ -479,22 +469,43 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args inl_exp other = other -{- Note [Improving conditionals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - CmmCondBranch ((a >## b) != 1) t f -where a,b, are Floats, the constant folder /cannot/ turn it into - CmmCondBranch (a <=## b) t f -because comparison on floats are not invertible -(see CmmMachOp.maybeInvertComparison). -What we want instead is simply to reverse the true/false branches thus +{- Note [improveConditional] + +cmmMachOpFold tries to simplify conditionals to turn things like + (a == b) != 1 +into + (a != b) +but there's one case it can't handle: when the comparison is over +floating-point values, we can't invert it, because floating-point +comparisions aren't invertible (because NaN). + +But we *can* optimise this conditional by swapping the true and false +branches. Given CmmCondBranch ((a >## b) != 1) t f ---> +we can turn it into CmmCondBranch (a >## b) f t -And we do that right here in tryToInline, just as we do cmmMachOpFold. +So here we catch conditionals that weren't optimised by cmmMachOpFold, +and apply above transformation to eliminate the comparison against 1. + +It's tempting to just turn every != into == and then let cmmMachOpFold +do its thing, but that risks changing a nice fall-through conditional +into one that requires two jumps. (see swapcond_last in +CmmContFlowOpt), so instead we carefully look for just the cases where +we can eliminate a comparison. -} +improveConditional :: CmmNode O x -> CmmNode O x +improveConditional + (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l) + | neLike mop, isComparisonExpr x + = CmmCondBranch x f t (fmap not l) + where + neLike (MO_Ne _) = True + neLike (MO_U_Lt _) = True -- (x<y) < 1 behaves like (x<y) != 1 + neLike (MO_S_Lt _) = True -- (x<y) < 1 behaves like (x<y) != 1 + neLike _ = False +improveConditional other = other -- Note [dependent assignments] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 4a1d874d8f..53dbcddfbb 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GADTs, RankNTypes #-} +{-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- -- @@ -35,7 +35,7 @@ module CmmUtils( cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord, cmmToWord, - isTrivialCmmExpr, hasNoGlobalRegs, + isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -56,17 +56,15 @@ module CmmUtils( -- * Operations that probably don't belong here modifyGraph, - ofBlockMap, toBlockMap, insertBlock, + ofBlockMap, toBlockMap, ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, - foldlGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1, + foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, -- * Ticks blockTicks ) where -#include "HsVersions.h" - import GhcPrelude import TyCon ( PrimRep(..), PrimElemRep(..) ) @@ -78,11 +76,9 @@ import BlockId import CLabel import Outputable import DynFlags -import Util import CodeGen.Platform import Data.Word -import Data.Maybe import Data.Bits import Hoopl.Graph import Hoopl.Label @@ -389,6 +385,14 @@ hasNoGlobalRegs (CmmReg (CmmLocal _)) = True hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True hasNoGlobalRegs _ = False +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False + +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False + --------------------------------------------------- -- -- Tagging @@ -487,12 +491,6 @@ toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} -insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock -insertBlock block map = - ASSERT(isNothing $ mapLookup id map) - mapInsert id block map - where id = entryLabel block - toBlockList :: CmmGraph -> [CmmBlock] toBlockList g = mapElems $ toBlockMap g @@ -558,8 +556,9 @@ mapGraphNodes1 f = modifyGraph (mapGraph f) foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g -postorderDfs :: CmmGraph -> [CmmBlock] -postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g) +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) ------------------------------------------------- -- Tick utilities diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs index b8072b37a7..ef7de4a078 100644 --- a/compiler/cmm/Hoopl/Collections.hs +++ b/compiler/cmm/Hoopl/Collections.hs @@ -12,7 +12,7 @@ module Hoopl.Collections import GhcPrelude -import qualified Data.IntMap as M +import qualified Data.IntMap.Strict as M import qualified Data.IntSet as S import Data.List (foldl', foldl1') @@ -66,6 +66,7 @@ class IsMap map where mapInsert :: KeyOf map -> a -> map a -> map a mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a mapDelete :: KeyOf map -> map a -> map a + mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a mapUnion :: map a -> map a -> map a mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a @@ -143,6 +144,7 @@ instance IsMap UniqueMap where mapInsert k v (UM m) = UM (M.insert k v m) mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) mapDelete k (UM m) = UM (M.delete k m) + mapAlter f k (UM m) = UM (M.alter f k m) mapUnion (UM x) (UM y) = UM (M.union x y) mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y) diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index 0b0434bb36..2538b70ee3 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -111,8 +111,7 @@ analyzeCmm dir lattice transfer cmmGraph initFact = blockMap = case hooplGraph of GMany NothingO bm NothingO -> bm - entries = if mapNull initFact then [entry] else mapKeys initFact - in fixpointAnalysis dir lattice transfer entries blockMap initFact + in fixpointAnalysis dir lattice transfer entry blockMap initFact -- Fixpoint algorithm. fixpointAnalysis @@ -120,16 +119,16 @@ fixpointAnalysis Direction -> DataflowLattice f -> TransferFun f - -> [Label] + -> Label -> LabelMap CmmBlock -> FactBase f -> FactBase f -fixpointAnalysis direction lattice do_block entries blockmap = loop start +fixpointAnalysis direction lattice do_block entry blockmap = loop start where -- Sorting the blocks helps to minimize the number of times we need to -- process blocks. For instance, for forward analysis we want to look at -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks direction entries blockmap + blocks = sortBlocks direction entry blockmap num_blocks = length blocks block_arr = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks start = {-# SCC "start" #-} IntSet.fromDistinctAscList @@ -174,9 +173,8 @@ rewriteCmm dir lattice rwFun cmmGraph initFact = do blockMap1 = case hooplGraph of GMany NothingO bm NothingO -> bm - entries = if mapNull initFact then [entry] else mapKeys initFact (blockMap2, facts) <- - fixpointRewrite dir lattice rwFun entries blockMap1 initFact + fixpointRewrite dir lattice rwFun entry blockMap1 initFact return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts) fixpointRewrite @@ -184,16 +182,16 @@ fixpointRewrite Direction -> DataflowLattice f -> RewriteFun f - -> [Label] + -> Label -> LabelMap CmmBlock -> FactBase f -> UniqSM (LabelMap CmmBlock, FactBase f) -fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap +fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap where -- Sorting the blocks helps to minimize the number of times we need to -- process blocks. For instance, for forward analysis we want to look at -- blocks in reverse postorder. Also, see comments for sortBlocks. - blocks = sortBlocks dir entries blockmap + blocks = sortBlocks dir entry blockmap num_blocks = length blocks block_arr = {-# SCC "block_arr_rewrite" #-} listArray (0, num_blocks - 1) blocks @@ -268,20 +266,15 @@ we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. -- | Sort the blocks into the right order for analysis. This means reverse -- postorder for a forward analysis. For the backward one, we simply reverse -- that (see Note [Backward vs forward analysis]). --- --- Note: We're using Hoopl's confusingly named `postorder_dfs_from` but AFAICS --- it returns the *reverse* postorder of the blocks (it visits blocks in the --- postorder and uses (:) to collect them, which gives the reverse of the --- visitation order). sortBlocks :: NonLocal n - => Direction -> [Label] -> LabelMap (Block n C C) -> [Block n C C] -sortBlocks direction entries blockmap = + => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C] +sortBlocks direction entry blockmap = case direction of Fwd -> fwd Bwd -> reverse fwd where - fwd = postorder_dfs_from blockmap entries + fwd = revPostorderFrom blockmap entry -- Note [Backward vs forward analysis] -- diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs index ca482ab4a8..0142f70c76 100644 --- a/compiler/cmm/Hoopl/Graph.hs +++ b/compiler/cmm/Hoopl/Graph.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -14,11 +15,12 @@ module Hoopl.Graph , labelsDefined , mapGraph , mapGraphBlocks - , postorder_dfs_from + , revPostorderFrom ) where import GhcPrelude +import Util import Hoopl.Label import Hoopl.Block @@ -51,13 +53,14 @@ emptyBody = mapEmpty bodyList :: Body' block n -> [(Label,block n C C)] bodyList body = mapToList body -addBlock :: NonLocal thing - => thing C C -> LabelMap (thing C C) - -> LabelMap (thing C C) -addBlock b body - | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph" - | otherwise = mapInsert lbl b body - where lbl = entryLabel b +addBlock + :: (NonLocal block, HasDebugCallStack) + => block C C -> LabelMap (block C C) -> LabelMap (block C C) +addBlock block body = mapAlter add lbl body + where + lbl = entryLabel block + add Nothing = Just block + add _ = error $ "duplicate label " ++ show lbl ++ " in graph" -- --------------------------------------------------------------------------- @@ -119,22 +122,10 @@ labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body ---------------------------------------------------------------- -class LabelsPtr l where - targetLabels :: l -> [Label] - -instance NonLocal n => LabelsPtr (n e C) where - targetLabels n = successors n - -instance LabelsPtr Label where - targetLabels l = [l] - -instance LabelsPtr LabelSet where - targetLabels = setElems - -instance LabelsPtr l => LabelsPtr [l] where - targetLabels = concatMap targetLabels - --- | This is the most important traversal over this data structure. It drops +-- | Returns a list of blocks reachable from the provided Labels in the reverse +-- postorder. +-- +-- This is the most important traversal over this data structure. It drops -- unreachable code and puts blocks in an order that is good for solving forward -- dataflow problems quickly. The reverse order is good for solving backward -- dataflow problems quickly. The forward order is also reasonably good for @@ -143,59 +134,52 @@ instance LabelsPtr l => LabelsPtr [l] where -- that you would need a more serious analysis, probably based on dominators, to -- identify loop headers. -- --- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' --- representation, when for most purposes the plain 'Graph' representation is --- more mathematically elegant (but results in more complicated code). --- --- Here's an easy way to go wrong! Consider +-- For forward analyses we want reverse postorder visitation, consider: -- @ -- A -> [B,C] -- B -> D -- C -> D -- @ --- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. --- Better to get [A,B,C,D] - - --- | Traversal: 'postorder_dfs' returns a list of blocks reachable --- from the entry of enterable graph. The entry and exit are *not* included. --- The list has the following property: --- --- Say a "back reference" exists if one of a block's --- control-flow successors precedes it in the output list --- --- Then there are as few back references as possible --- --- The output is suitable for use in --- a forward dataflow problem. For a backward problem, simply reverse --- the list. ('postorder_dfs' is sufficiently tricky to implement that --- one doesn't want to try and maintain both forward and backward --- versions.) - -postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) - => LabelMap (block C C) -> e -> LabelSet -> [block C C] -postorder_dfs_from_except blocks b visited = - vchildren (get_children b) (\acc _visited -> acc) [] visited - where - vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a - vnode block cont acc visited = - if setMember id visited then - cont acc visited - else - let cont' acc visited = cont (block:acc) visited in - vchildren (get_children block) cont' acc (setInsert id visited) - where id = entryLabel block - vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a - vchildren bs cont acc visited = next bs acc visited - where next children acc visited = - case children of [] -> cont acc visited - (b:bs) -> vnode b (next bs) acc visited - get_children :: forall l. LabelsPtr l => l -> [block C C] - get_children block = foldr add_id [] $ targetLabels block - add_id id rst = case lookupFact id blocks of - Just b -> b : rst - Nothing -> rst - -postorder_dfs_from - :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] -postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty +-- Postorder: [D, C, B, A] (or [D, B, C, A]) +-- Reverse postorder: [A, B, C, D] (or [A, C, B, D]) +-- This matters for, e.g., forward analysis, because we want to analyze *both* +-- B and C before we analyze D. +revPostorderFrom + :: forall block. (NonLocal block) + => LabelMap (block C C) -> Label -> [block C C] +revPostorderFrom graph start = go start_worklist setEmpty [] + where + start_worklist = lookup_for_descend start Nil + + -- To compute the postorder we need to "visit" a block (mark as done) + -- *after* visiting all its successors. So we need to know whether we + -- already processed all successors of each block (and @NonLocal@ allows + -- arbitrary many successors). So we use an explicit stack with an extra bit + -- of information: + -- * @ConsTodo@ means to explore the block if it wasn't visited before + -- * @ConsMark@ means that all successors were already done and we can add + -- the block to the result. + -- + -- NOTE: We add blocks to the result list in postorder, but we *prepend* + -- them (i.e., we use @(:)@), which means that the final list is in reverse + -- postorder. + go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C] + go Nil !_ !result = result + go (ConsMark block rest) !wip_or_done !result = + go rest wip_or_done (block : result) + go (ConsTodo block rest) !wip_or_done !result + | entryLabel block `setMember` wip_or_done = go rest wip_or_done result + | otherwise = + let new_worklist = + foldr lookup_for_descend + (ConsMark block rest) + (successors block) + in go new_worklist (setInsert (entryLabel block) wip_or_done) result + + lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C) + lookup_for_descend label wl + | Just b <- mapLookup label graph = ConsTodo b wl + | otherwise = + error $ "Label that doesn't have a block?! " ++ show label + +data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs index 8096fab073..6eae115779 100644 --- a/compiler/cmm/Hoopl/Label.hs +++ b/compiler/cmm/Hoopl/Label.hs @@ -87,6 +87,7 @@ instance IsMap LabelMap where mapInsert (Label k) v (LM m) = LM (mapInsert k v m) mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) mapDelete (Label k) (LM m) = LM (mapDelete k m) + mapAlter f (Label k) (LM m) = LM (mapAlter f k m) mapUnion (LM x) (LM y) = LM (mapUnion x y) mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index d9f140254c..70229d067d 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, GADTs #-} +{-# LANGUAGE BangPatterns, GADTs #-} module MkGraph ( CmmAGraph, CmmAGraphScoped, CgStmt(..) @@ -21,7 +21,7 @@ module MkGraph ) where -import GhcPrelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>) +import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>) import BlockId import Cmm @@ -37,10 +37,7 @@ import ForeignCall import OrdList import SMRep (ByteOff) import UniqSupply - -import Control.Monad -import Data.List -import Data.Maybe +import Util ----------------------------------------------------------------------------- @@ -184,12 +181,10 @@ mkNop :: CmmAGraph mkNop = nilOL mkComment :: FastString -> CmmAGraph -#if defined(DEBUG) --- SDM: generating all those comments takes time, this saved about 4% for me -mkComment fs = mkMiddle $ CmmComment fs -#else -mkComment _ = nilOL -#endif +mkComment fs + -- SDM: generating all those comments takes time, this saved about 4% for me + | debugIsOn = mkMiddle $ CmmComment fs + | otherwise = nilOL ---------- Assignment and store mkAssign :: CmmReg -> CmmExpr -> CmmAGraph diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 6a93ea818e..c9a6003aaf 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -141,8 +141,8 @@ pprCmmGraph g = text "{" <> text "offset" $$ nest 2 (vcat $ map ppr blocks) $$ text "}" - where blocks = postorderDfs g - -- postorderDfs has the side-effect of discarding unreachable code, + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, -- so pretty-printed Cmm will omit any unreachable blocks. This can -- sometimes be confusing. diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 9b3cecc3b8..9dd2332b67 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ---------------------------------------------------------------------------- -- -- Pretty-printing of common Cmm types @@ -54,7 +52,6 @@ import System.IO -- Temp Jan08 import SMRep -#include "../includes/rts/storage/FunTypes.h" pprCmms :: (Outputable info, Outputable g) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index c20f1fd1d0..6a2840294a 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GADTs #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- @@ -10,8 +10,6 @@ module CgUtils ( fixStgRegisters ) where -#include "HsVersions.h" - import GhcPrelude import CodeGen.Platform diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 9ef552d336..b29394da6f 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: bindings @@ -15,8 +13,6 @@ module StgCmmBind ( pushUpdateFrame, emitUpdateFrame ) where -#include "HsVersions.h" - import GhcPrelude hiding ((<*>)) import StgCmmExpr diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 3fcc935121..22fcfaf412 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} ----------------------------------------------------------------------------- -- @@ -61,7 +60,8 @@ cgExpr :: StgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args -{- seq# a s ==> a -} +-- seq# a s ==> a +-- See Note [seq# magic] in PrelRules cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] @@ -409,7 +409,8 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; v_info <- getCgIdInfo v ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) - ; bindArgToReg (NonVoid bndr) + -- Add bndr to the environment + ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr @@ -435,7 +436,8 @@ it would be better to invoke some kind of panic function here. cgCase scrut@(StgApp v []) _ (PrimAlt _) _ = do { dflags <- getDynFlags ; mb_cc <- maybeSaveCostCentre True - ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) + ; _ <- withSequel + (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId @@ -446,13 +448,14 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ {- Note [Handle seq#] ~~~~~~~~~~~~~~~~~~~~~ -case seq# a s of v - (# s', a' #) -> e +See Note [seq# magic] in PrelRules. +The special case for seq# in cgCase does this: + case seq# a s of v + (# s', a' #) -> e ==> - -case a of v - (# s', a' #) -> e + case a of v + (# s', a' #) -> e (taking advantage of the fact that the return convention for (# State#, a #) is the same as the return convention for just 'a') @@ -460,6 +463,7 @@ is the same as the return convention for just 'a') cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts = -- Note [Handle seq#] + -- And see Note [seq# magic] in PrelRules -- Use the same return convention as vanilla 'a'. cgCase (StgApp a []) bndr alt_type alts diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index d0ad17f59b..c1103e7d77 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- -- Code generation for foreign calls. @@ -20,8 +18,6 @@ module StgCmmForeign ( emitCloseNursery, ) where -#include "HsVersions.h" - import GhcPrelude hiding( succ, (<*>) ) import StgSyn @@ -408,8 +404,8 @@ Opening the nursery corresponds to the following code: @ tso = CurrentTSO; cn = CurrentNursery; - bdfree = CurrentNuresry->free; - bdstart = CurrentNuresry->start; + bdfree = CurrentNursery->free; + bdstart = CurrentNursery->start; // We *add* the currently occupied portion of the nursery block to // the allocation limit, because we will subtract it again in diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 07633ed4ae..3be35b35fa 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions @@ -22,8 +20,6 @@ module StgCmmHeap ( emitSetDynHdr ) where -#include "HsVersions.h" - import GhcPrelude hiding ((<*>)) import StgSyn diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 7c3864296c..cc941a2e57 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GADTs, UnboxedTuples #-} +{-# LANGUAGE GADTs, UnboxedTuples #-} ----------------------------------------------------------------------------- -- @@ -58,8 +58,6 @@ module StgCmmMonad ( CgInfoDownwards(..), CgState(..) -- non-abstract ) where -#include "HsVersions.h" - import GhcPrelude hiding( sequence, succ ) import Cmm @@ -79,6 +77,7 @@ import Unique import UniqSupply import FastString import Outputable +import Util import Control.Monad import Data.List @@ -696,11 +695,9 @@ emitLabel id = do tscope <- getTickScope emitCgStmt (CgLabel id tscope) emitComment :: FastString -> FCode () -#if 0 /* def DEBUG */ -emitComment s = emitCgStmt (CgStmt (CmmComment s)) -#else -emitComment _ = return () -#endif +emitComment s + | debugIsOn = emitCgStmt (CgStmt (CmmComment s)) + | otherwise = return () emitTick :: CmmTickish -> FCode () emitTick = emitCgStmt . CgStmt . CmmTick diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index a0bca5d661..15c31ca59c 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- -- Code generation for profiling @@ -25,8 +23,6 @@ module StgCmmProf ( ldvEnter, ldvEnterClosure, ldvRecordCreate ) where -#include "HsVersions.h" - import GhcPrelude import StgCmmClosure diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index a7d158ce3a..8f3074856a 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- @@ -104,8 +104,6 @@ module StgCmmTicky ( tickySlowCall, tickySlowCallPat, ) where -#include "HsVersions.h" - import GhcPrelude import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString ) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 4db9d8fc29..5608afc334 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1449,8 +1449,11 @@ app_ok primop_ok fun args -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner loop + | SeqOp <- op -- See Note [seq# and expr_ok] + -> all (expr_ok primop_ok) args + | otherwise - -> primop_ok op -- Check the primop itself + -> primop_ok op -- Check the primop itself && and (zipWith arg_ok arg_tys args) -- Check the arguments _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF @@ -1607,6 +1610,25 @@ See also Note [dataToTag#] in primops.txt.pp. Bottom line: * in exprOkForSpeculation we simply ignore all lifted arguments. + * except see Note [seq# and expr_ok] for an exception + + +Note [seq# and expr_ok] +~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + seq# :: forall a s . a -> State# s -> (# State# s, a #) +must always evaluate its first argument. So it's really a +counter-example to Note [Primops with lifted arguments]. In +the case of seq# we must check the argument to seq#. Remember +item (d) of the specification of exprOkForSpeculation: + + -- Precisely, it returns @True@ iff: + -- a) The expression guarantees to terminate, + ... + -- d) without throwing a Haskell exception + +The lack of this special case caused Trac #5129 to go bad again. +See comment:24 and following ************************************************************************ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 531f146a9d..644075810c 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -1625,8 +1625,14 @@ thRdrName loc ctxt_ns th_occ th_name occ :: OccName.OccName occ = mk_occ ctxt_ns th_occ +-- Return an unqualified exact RdrName if we're dealing with built-in syntax. +-- See Trac #13776. thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName -thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) +thOrigRdrName occ th_ns pkg mod = + let occ' = mk_occ (mk_ghc_ns th_ns) occ + in case isBuiltInOcc_maybe occ' of + Just name -> nameRdrName name + Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' thRdrNameGuesses :: TH.Name -> [RdrName] thRdrNameGuesses (TH.Name occ flavour) diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 0c5922eb53..d0adce99ee 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -257,6 +257,10 @@ data IfaceCoercion | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion | IfaceCoVarCo IfLclName | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + -- There are only a fixed number of CoAxiomRules, so it suffices + -- to use an IfaceLclName to distinguish them. + -- See Note [Adding built-in type families] in TcTypeNats | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion @@ -266,7 +270,6 @@ data IfaceCoercion | IfaceCoherenceCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion | IfaceSubCo IfaceCoercion - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 70438f6337..ca1a17dba4 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -1359,7 +1359,7 @@ tcIfaceCo = go <*> go c2 go (IfaceKindCo c) = KindCo <$> go c go (IfaceSubCo c) = SubCo <$> go c - go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax + go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax <*> mapM go cos go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) @@ -1367,12 +1367,6 @@ tcIfaceCo = go go_var :: FastString -> IfL CoVar go_var = tcIfaceLclId - go_axiom_rule :: FastString -> IfL CoAxiomRule - go_axiom_rule n = - case Map.lookup n typeNatCoAxiomRules of - Just ax -> return ax - _ -> pprPanic "go_axiom_rule" (ppr n) - tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco @@ -1808,6 +1802,16 @@ tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name ; return (tyThingCoAxiom thing) } + +tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule +-- Unlike CoAxioms, which arise form user 'type instance' declarations, +-- there are a fixed set of CoAxiomRules, +-- currently enumerated in typeNatCoAxiomRules +tcIfaceCoAxiomRule n + = case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) + tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 7b9cb13254..0d018a7ec4 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -59,6 +59,7 @@ module DynFlags ( tablesNextToCode, mkTablesNextToCode, makeDynFlagsConsistent, shouldUseColor, + shouldUseHexWordLiterals, positionIndependent, optimisationFlags, @@ -449,6 +450,7 @@ data GeneralFlag | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn + | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively | Opt_CrossModuleSpecialise @@ -566,6 +568,7 @@ data GeneralFlag | Opt_NoSortValidSubstitutions | Opt_AbstractRefSubstitutions | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] -- Suppress all coercions, them replacing with '...' | Opt_SuppressCoercions @@ -631,6 +634,7 @@ optimisationFlags = EnumSet.fromList , Opt_KillOneShot , Opt_FullLaziness , Opt_FloatIn + , Opt_LateSpecialise , Opt_Specialise , Opt_SpecialiseAggressively , Opt_CrossModuleSpecialise @@ -1482,6 +1486,10 @@ data RtsOptsEnabled shouldUseColor :: DynFlags -> Bool shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) +shouldUseHexWordLiterals :: DynFlags -> Bool +shouldUseHexWordLiterals dflags = + Opt_HexWordLiterals `EnumSet.member` generalFlags dflags + -- | Are we building with @-fPIE@ or @-fPIC@ enabled? positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags @@ -3007,6 +3015,8 @@ dynamic_flags_deps = [ (NoArg (setRtsOptsEnabled RtsOptsNone)) , make_ord_flag defGhcFlag "no-rtsopts-suggestions" (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) @@ -3929,6 +3939,7 @@ fFlagsDeps = [ flagSpec "kill-absence" Opt_KillAbsence, flagSpec "kill-one-shot" Opt_KillOneShot, flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, flagSpec "liberate-case" Opt_LiberateCase, flagSpec "llvm-pass-vectors-in-regs" Opt_LlvmPassVectorsInRegisters, flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index a8efb6013d..7440e5db00 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -5,13 +5,15 @@ import Platform data DynFlags data DumpFlag +data GeneralFlag -targetPlatform :: DynFlags -> Platform -pprUserLength :: DynFlags -> Int -pprCols :: DynFlags -> Int -unsafeGlobalDynFlags :: DynFlags -useUnicode :: DynFlags -> Bool -useUnicodeSyntax :: DynFlags -> Bool -shouldUseColor :: DynFlags -> Bool -hasPprDebug :: DynFlags -> Bool -hasNoDebugOutput :: DynFlags -> Bool +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +useUnicode :: DynFlags -> Bool +useUnicodeSyntax :: DynFlags -> Bool +shouldUseColor :: DynFlags -> Bool +shouldUseHexWordLiterals :: DynFlags -> Bool +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index e2c568c836..7c345f2328 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -382,6 +382,14 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do mov_lo = MR rlo expr_reg return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) rlo + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + (expr_reg,expr_code) <- getSomeReg expr + (rlo, rhi) <- getNewRegPairNat II32 + let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31)) + mov_lo = MR rlo expr_reg + return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) + rlo iselExpr64 expr = pprPanic "iselExpr64(powerpc)" (pprExpr expr) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 8549fa07ee..6fa7482f9b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -193,6 +193,24 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) return $ ChildCode64 code r_dst_lo +-- only W32 supported for now +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + -- compute expr and load it into r_dst_lo + (a_reg, a_code) <- getSomeReg expr + + dflags <- getDynFlags + let platform = targetPlatform dflags + code = a_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi + , mkRegRegMoveInstr platform a_reg r_dst_lo ] + + return $ ChildCode64 code r_dst_lo + iselExpr64 expr = pprPanic "iselExpr64(sparc)" (ppr expr) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 09757e769e..a0b0673d27 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -468,6 +468,20 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do r_dst_lo ) +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + fn <- getAnyReg expr + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + code = fn r_dst_lo + return ( + ChildCode64 (code `snocOL` + MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL` + CLTD II32 `snocOL` + MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL` + MOV II32 (OpReg edx) (OpReg r_dst_hi)) + r_dst_lo + ) + iselExpr64 expr = pprPanic "iselExpr64(i386)" (ppr expr) diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 73484b7c35..14e3f0f36e 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -942,7 +942,56 @@ dataToTagRule = a `mplus` b ************************************************************************ -} --- seq# :: forall a s . a -> State# s -> (# State# s, a #) +{- Note [seq# magic] +~~~~~~~~~~~~~~~~~~~~ +The primop + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is /not/ the same as the Prelude function seq :: a -> b -> b +as you can see from its type. In fact, seq# is the implementation +mechanism for 'evaluate' + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +The semantics of seq# is + * evaluate its first argument + * and return it + +Things to note + +* Why do we need a primop at all? That is, instead of + case seq# x s of (# x, s #) -> blah + why not instead say this? + case x of { DEFAULT -> blah) + + Reason (see Trac #5129): if we saw + catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler + + then we'd drop the 'case x' because the body of the case is bottom + anyway. But we don't want to do that; the whole /point/ of + seq#/evaluate is to evaluate 'x' first in the IO monad. + + In short, we /always/ evaluate the first argument and never + just discard it. + +* Why return the value? So that we can control sharing of seq'd + values: in + let x = e in x `seq` ... x ... + We don't want to inline x, so better to represent it as + let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + also it matches the type of rseq in the Eval monad. + +Implementing seq#. The compiler has magic for SeqOp in + +- PrelRules.seqRule: eliminate (seq# <whnf> s) + +- StgCmmExpr.cgExpr, and cgCase: special case for seq# + +- CoreUtils.exprOkForSpeculation; + see Note [seq# and expr_ok] in CoreUtils +-} + seqRule :: RuleM CoreExpr seqRule = do [Type ty_a, Type _ty_s, a, s] <- getArgs diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 038d350a76..996e0bb3e8 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2697,13 +2697,7 @@ primop SparkOp "spark#" GenPrimOp primop SeqOp "seq#" GenPrimOp a -> State# s -> (# State# s, a #) - - -- why return the value? So that we can control sharing of seq'd - -- values: in - -- let x = e in x `seq` ... x ... - -- we don't want to inline x, so better to represent it as - -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ... - -- also it matches the type of rseq in the Eval monad. + -- See Note [seq# magic] in PrelRules primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) @@ -2942,6 +2936,20 @@ primop TraceMarkerOp "traceMarker#" GenPrimOp has_side_effects = True out_of_line = True +primop GetThreadAllocationCounter "getThreadAllocationCounter#" GenPrimOp + State# RealWorld -> (# State# RealWorld, INT64 #) + { Retrieves the allocation counter for the current thread. } + with + has_side_effects = True + out_of_line = True + +primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp + INT64 -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the current thread to the given value. } + with + has_side_effects = True + out_of_line = True + ------------------------------------------------------------------------ section "Safe coercions" ------------------------------------------------------------------------ diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 769b34e45b..af00056271 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -1401,9 +1401,12 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) pp_mod = ppr (unLoc (ideclName decl)) pp_not_used = text "is redundant" + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See trac#14881. ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, p) -> ppr p <> parens (ppr fld) - Nothing -> ppr n + Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) + Nothing -> pprNameUnqualified n -- Print unused names in a deterministic (lexicographic) order sort_unused = pprWithCommas ppr_possible_field $ diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 41f0a9a495..2bea6dd05d 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -17,7 +17,8 @@ import CoreSyn import HscTypes import CSE ( cseProgram ) import Rules ( mkRuleBase, unionRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, ) + extendRuleBaseList, ruleCheckProgram, addRuleInfo, + getRules ) import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo @@ -130,6 +131,7 @@ getCoreToDo dflags spec_constr = gopt Opt_SpecConstr dflags liberate_case = gopt Opt_LiberateCase dflags late_dmd_anal = gopt Opt_LateDmdAnal dflags + late_specialise = gopt Opt_LateSpecialise dflags static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags @@ -350,6 +352,10 @@ getCoreToDo dflags maybe_rule_check (Phase 0), + runWhen late_specialise + (CoreDoPasses [ CoreDoSpecialising + , simpl_phase 0 ["post-late-spec"] max_iter]), + -- Final clean-up simplification: simpl_phase 0 ["final"] max_iter, @@ -520,10 +526,12 @@ ruleCheckPass current_phase pat guts = { rb <- getRuleBase ; dflags <- getDynFlags ; vis_orphs <- getVisibleOrphanMods + ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn + ++ (mg_rules guts) ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan (defaultDumpStyle dflags) (ruleCheckProgram current_phase pat - (RuleEnv rb vis_orphs) (mg_binds guts)) + rule_fn (mg_binds guts)) ; return guts } doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 319404ef15..b6025955ac 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -1148,10 +1148,10 @@ is so important. -- string for the purposes of error reporting ruleCheckProgram :: CompilerPhase -- ^ Rule activation test -> String -- ^ Rule pattern - -> RuleEnv -- ^ Database of rules + -> (Id -> [CoreRule]) -- ^ Rules for an Id -> CoreProgram -- ^ Bindings to check in -> SDoc -- ^ Resulting check message -ruleCheckProgram phase rule_pat rule_base binds +ruleCheckProgram phase rule_pat rules binds | isEmptyBag results = text "Rule check results: no rule application sites" | otherwise @@ -1164,7 +1164,7 @@ ruleCheckProgram phase rule_pat rule_base binds , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat - , rc_rule_base = rule_base } + , rc_rules = rules } results = unionManyBags (map (ruleCheckBind env) binds) line = text (replicate 20 '-') @@ -1172,7 +1172,7 @@ data RuleCheckEnv = RuleCheckEnv { rc_is_active :: Activation -> Bool, rc_id_unf :: IdUnfoldingFun, rc_pattern :: String, - rc_rule_base :: RuleEnv + rc_rules :: Id -> [CoreRule] } ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc @@ -1206,7 +1206,7 @@ ruleCheckFun env fn args | null name_match_rules = emptyBag | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where - name_match_rules = filter match (getRules (rc_rule_base env) fn) + name_match_rules = filter match (rc_rules env fn) match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index efd56ce77c..f62f7d0778 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -57,6 +57,7 @@ import UniqFM import MonadUtils import Control.Monad ( zipWithM ) import Data.List +import Data.Maybe ( fromMaybe ) import PrelNames ( specTyConName ) import Module import TyCon ( TyCon ) @@ -1509,6 +1510,7 @@ data OneSpec = OS { os_pat :: CallPat -- Call pattern that generated this specialisation , os_rule :: CoreRule -- Rule connecting original id with the specialisation , os_id :: OutId -- Spec id + , os_orig_id :: OutId -- The original id , os_rhs :: OutExpr } -- Spec rhs noSpecInfo :: SpecInfo @@ -1522,7 +1524,8 @@ specNonRec :: ScEnv -- plus details of specialisations specNonRec env body_usg rhs_info - = specialise env (scu_calls body_usg) rhs_info + = addPatUsages env (scu_calls body_usg) <$> + specialise env (scu_calls body_usg) rhs_info (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) ---------------------- @@ -1533,7 +1536,8 @@ specRec :: TopLevelFlag -> ScEnv -- plus details of specialisations specRec top_lvl env body_usg rhs_infos - = go 1 seed_calls nullUsage init_spec_infos + = addPatUsagess env (scu_calls body_usg) <$> + go 1 seed_calls nullUsage init_spec_infos where (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] | isTopLevel top_lvl @@ -1754,8 +1758,64 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) -- See Note [Transfer activation] ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id + , os_orig_id = fn , os_rhs = spec_rhs }) } +-- See Note [ArgOcc from calls to specialized functions] +addPatUsagess :: ScEnv -> CallEnv -> (ScUsage, [SpecInfo]) -> (ScUsage, [SpecInfo]) +addPatUsagess env body_calls (usg, spec_infos) = (usg `combineUsage` extra_usages, spec_infos) + where extra_usages = combineUsages [ extraPatUsages env body_calls si | si <- spec_infos ] + +addPatUsages :: ScEnv -> CallEnv -> (ScUsage, SpecInfo) -> (ScUsage, SpecInfo) +addPatUsages env body_calls (usg, spec_info) = (usg `combineUsage` extra_usage, spec_info) + where extra_usage = extraPatUsages env body_calls spec_info + +extraPatUsages :: ScEnv -> CallEnv -> SpecInfo -> ScUsage +extraPatUsages env body_calls si = combineUsages + [ patToCallUsage env call_pat call + | os <- si_specs si + , let fn = os_orig_id os + call_pat = os_pat os + , pprTrace "add_pat_usages" (ppr fn <+> ppr call_pat) True + , call <- fromMaybe [] $ lookupVarEnv body_calls fn + ] + +patToCallUsage :: ScEnv -> CallPat -> Call -> ScUsage +patToCallUsage env (_qvars, pats) (Call _ args _) + = pprTrace "patToCallUsage" (ppr pats <+> ppr args <+> ppr usage) $ + usage + where + usage = combineUsages $ zipWith go pats args + + go :: CoreExpr -> CoreExpr -> ScUsage + -- The interesting case + go pat (Var v) + | Just RecArg <- lookupHowBound env v + , arg_occ@ScrutOcc{} <- patToArgOcc pat -- skip if we get UnkOcc + = nullUsage { scu_occs = unitVarEnv v arg_occ } + + -- Transparent cases + go (Tick _ p) e = go p e + go (Cast p _) e = go p e + go p (Tick _ e) = go p e + go p (Cast e _) = go p e + + + -- Traverse the tree + go (App pf pa) (App f a) + = go pf f `combineUsage` go pa a + + -- Boring catch-all + go _ _ = nullUsage + +patToArgOcc :: CoreExpr -> ArgOcc +patToArgOcc e@App{} + | (Var f, args) <- collectArgs e + , Just dc <- isDataConWorkId_maybe f + = let arg_occs = [ patToArgOcc arg | arg <- args, not (isTypeArg arg) ] + in ScrutOcc $ unitUFM dc arg_occs +patToArgOcc _ + = UnkOcc -- See Note [Strictness information in worker binders] handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] @@ -1792,6 +1852,42 @@ calcSpecStrictness fn qvars pats go_one env _ _ = env {- +Note [ArgOcc from calls to specialized functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We collect the ArgOcc to find out which parameters are being scrutinized in the +body function, and only generate specializations when they would lead to some +optimization: In + + foo x = … case x of (a,b) -> … + +We are willing to specialize foo. If we have + + foo x = … bar x … + where bar y = … + +we normally don’t. But what if we specialize bar? Then we have + + foo x = … bar x … + where $sbar a b = … + bar y = … + {-# RULE forall a b. bar (a,b) = $sbar a b #-} + +and now it would be beneficial to create a specialized version of foo that +calls $sbar directly. + +To achieve this, after we specialize bar, we look at the calls to it (found in +scu_calls), and all the specializations that we created. If there is a call `bar x` +and a specialization pattern `(x,y)`, then we treat that as if we found a case +analysis of x, and include `x ↦ ScrutOcc` in scu_occs. This unblocks specialization +of foo, and so on. + +(We might want to generalize this to any call to `baz x` where `baz` has +rewrite rules that match on constructor arguments, not only for when _we_ _just_ +created specializations.) + +(See #14951) + Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In calls to 'specialise', the returned ScUsage must include the rhs_usg in diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 9f623fc0a5..7e44c4a32e 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -41,6 +41,7 @@ import TcUnify import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) +import Kind import Type import TcEvidence import TyCon @@ -680,7 +681,7 @@ tcDataFamInstDecl mb_clsinfo -- Deal with any kind signature. -- See also Note [Arity of data families] in FamInstEnv ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind' - ; checkTc (isLiftedTypeKind final_res_kind) (badKindSig True res_kind') + ; checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind') ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs all_pats = pats' `chkAppend` extra_pats @@ -722,7 +723,7 @@ tcDataFamInstDecl mb_clsinfo ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind final_res_kind) $ + ; checkTc (tcIsStarKind final_res_kind) $ tooFewParmsErr (tyConArity fam_tc) ; checkValidTyCon rep_tc diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 7436b0d690..39697d6d94 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -886,7 +886,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- Data families might have a variable return kind. -- See See Note [Arity of data families] in FamInstEnv. ; (extra_binders, final_res_kind) <- tcDataKindSig binders res_kind - ; checkTc (isLiftedTypeKind final_res_kind + ; checkTc (tcIsStarKind final_res_kind || isJust (tcGetCastedTyVar_maybe final_res_kind)) (badKindSig False res_kind) @@ -1038,7 +1038,7 @@ tcDataDefn roles_info ; let hsc_src = tcg_src tcg_env ; (extra_bndrs, final_res_kind) <- tcDataKindSig tycon_binders res_kind ; unless (mk_permissive_kind hsc_src cons) $ - checkTc (isLiftedTypeKind final_res_kind) (badKindSig True res_kind) + checkTc (tcIsStarKind final_res_kind) (badKindSig True res_kind) ; let final_bndrs = tycon_binders `chkAppend` extra_bndrs roles = roles_info tc_name diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 78e0b96e11..24e12cd15c 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -5,6 +5,9 @@ module TcTypeNats , typeNatCoAxiomRules , BuiltInSynFamily(..) + -- If you define a new built-in type family, make sure to export its TyCon + -- from here as well. + -- See Note [Adding built-in type families] , typeNatAddTyCon , typeNatMulTyCon , typeNatExpTyCon @@ -53,10 +56,86 @@ import Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List ( isPrefixOf, isSuffixOf ) +{- +Note [Type-level literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently two forms of type-level literals: natural numbers, and +symbols (even though this module is named TcTypeNats, it covers both). + +Type-level literals are supported by CoAxiomRules (conditional axioms), which +power the built-in type families (see Note [Adding built-in type families]). +Currently, all built-in type families are for the express purpose of supporting +type-level literals. + +See also the Wiki page: + + https://ghc.haskell.org/trac/ghc/wiki/TypeNats + +Note [Adding built-in type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few steps to adding a built-in type family: + +* Adding a unique for the type family TyCon + + These go in PrelNames. It will likely be of the form + @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that + has not been chosen before in PrelNames. There are several examples already + in PrelNames—see, for instance, typeNatAddTyFamNameKey. + +* Adding the type family TyCon itself + + This goes in TcTypeNats. There are plenty of examples of how to define + these—see, for instance, typeNatAddTyCon. + + Once your TyCon has been defined, be sure to: + + - Export it from TcTypeNats. (Not doing so caused #14632.) + - Include it in the typeNatTyCons list, defined in TcTypeNats. + +* Exposing associated type family axioms + + When defining the type family TyCon, you will need to define an axiom for + the type family in general (see, for instance, axAddDef), and perhaps other + auxiliary axioms for special cases of the type family (see, for instance, + axAdd0L and axAdd0R). + + After you have defined all of these axioms, be sure to include them in the + typeNatCoAxiomRules list, defined in TcTypeNats. + (Not doing so caused #14934.) + +* Define the type family somewhere + + Finally, you will need to define the type family somewhere, likely in @base@. + Currently, all of the built-in type families are defined in GHC.TypeLits or + GHC.TypeNats, so those are likely candidates. + + Since the behavior of your built-in type family is specified in TcTypeNats, + you should give an open type family definition with no instances, like so: + + type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat + + Changing the argument and result kinds as appropriate. + +* Update the relevant test cases + + The GHC test suite will likely need to be updated after you add your built-in + type family. For instance: + + - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added + a test there, the expected output of T9181 will need to change. + - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit + tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have + runtime unit tests. Consider adding further unit tests to those if your + built-in type family deals with Nats or Symbols, respectively. +-} + {------------------------------------------------------------------------------- Built-in type constructors for functions on type-level nats -} +-- The list of built-in type family TyCons that GHC uses. +-- If you define a built-in type family, make sure to add it to this list. +-- See Note [Adding built-in type families] typeNatTyCons :: [TyCon] typeNatTyCons = [ typeNatAddTyCon @@ -266,6 +345,7 @@ Built-in rules axioms -- If you add additional rules, please remember to add them to -- `typeNatCoAxiomRules` also. +-- See Note [Adding built-in type families] axAddDef , axMulDef , axExpDef @@ -375,6 +455,9 @@ axAppendSymbol0R = mkAxiom1 "Concat0R" axAppendSymbol0L = mkAxiom1 "Concat0L" $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t +-- The list of built-in type family axioms that GHC uses. +-- If you define new axioms, make sure to include them in this list. +-- See Note [Adding built-in type families] typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) [ axAddDef @@ -398,6 +481,7 @@ typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x)) , axCmpSymbolRefl , axLeq0L , axSubDef + , axSub0R , axAppendSymbol0R , axAppendSymbol0L , axDivDef diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 588963d012..cc425991ae 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -814,16 +814,17 @@ data Coercion -- any left over, we use AppCo. -- See [Coercion axioms applied to coercions] + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + | UnivCo UnivCoProvenance Role Type Type -- :: _ -> "e" -> _ -> _ -> e | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - | AxiomRuleCo CoAxiomRule [Coercion] - | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) -- Using NthCo on a ForAllCo gives an N coercion always diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 793b8fb139..2b03555bab 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -22,7 +22,7 @@ module Outputable ( empty, isEmpty, nest, char, text, ftext, ptext, ztext, - int, intWithCommas, integer, float, double, rational, doublePrec, + int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, paBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, @@ -91,7 +91,8 @@ import GhcPrelude import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, - shouldUseColor, unsafeGlobalDynFlags ) + shouldUseColor, unsafeGlobalDynFlags, + shouldUseHexWordLiterals ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) @@ -555,6 +556,7 @@ ptext :: LitString -> SDoc ztext :: FastZString -> SDoc int :: Int -> SDoc integer :: Integer -> SDoc +word :: Integer -> SDoc float :: Float -> SDoc double :: Double -> SDoc rational :: Rational -> SDoc @@ -573,6 +575,11 @@ integer n = docToSDoc $ Pretty.integer n float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n +word n = sdocWithDynFlags $ \dflags -> + -- See Note [Print Hexadecimal Literals] in Pretty.hs + if shouldUseHexWordLiterals dflags + then docToSDoc $ Pretty.hex n + else docToSDoc $ Pretty.integer n -- | @doublePrec p n@ shows a floating point number @n@ with @p@ -- digits of precision after the decimal point. @@ -969,9 +976,9 @@ pprPrimChar :: Char -> SDoc pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc pprPrimChar c = pprHsChar c <> primCharSuffix pprPrimInt i = integer i <> primIntSuffix -pprPrimWord w = integer w <> primWordSuffix +pprPrimWord w = word w <> primWordSuffix pprPrimInt64 i = integer i <> primInt64Suffix -pprPrimWord64 w = integer w <> primWord64Suffix +pprPrimWord64 w = word w <> primWord64Suffix --------------------- -- Put a name in parens if it's an operator diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index f4987d3751..9a12c7dae9 100644 --- a/compiler/utils/Pretty.hs +++ b/compiler/utils/Pretty.hs @@ -72,7 +72,7 @@ module Pretty ( -- ** Converting values into documents char, text, ftext, ptext, ztext, sizedText, zeroWidthText, - int, integer, float, double, rational, + int, integer, float, double, rational, hex, -- ** Simple derived documents semi, comma, colon, space, equals, @@ -117,6 +117,7 @@ import BufWrite import FastString import Panic import System.IO +import Numeric (showHex) --for a RULES import GHC.Base ( unpackCString# ) @@ -404,11 +405,18 @@ integer :: Integer -> Doc -- ^ @integer n = text (show n)@ float :: Float -> Doc -- ^ @float n = text (show n)@ double :: Double -> Doc -- ^ @double n = text (show n)@ rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] int n = text (show n) integer n = text (show n) float n = text (show n) double n = text (show n) rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ @@ -423,6 +431,57 @@ parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' braces p = char '{' <> p <> char '}' +{- +Note [Print Hexadecimal Literals] + +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://ghc.haskell.org/trac/ghc/ticket/14872 + +There is a flag `-dword-hex-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + -- | Apply 'parens' to 'Doc' if boolean is true. maybeParens :: Bool -> Doc -> Doc maybeParens False = id diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs index 2a9b806178..a80880f4e5 100644 --- a/compiler/utils/UniqFM.hs +++ b/compiler/utils/UniqFM.hs @@ -78,12 +78,10 @@ import Outputable import Data.List (foldl') import qualified Data.IntMap as M -import qualified Data.IntMap.Merge.Lazy as M -import Control.Applicative (Const (..)) -import qualified Data.Monoid as Mon import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) newtype UniqFM ele = UFM (M.IntMap ele) @@ -342,10 +340,7 @@ ufmToIntMap (UFM m) = m -- Determines whether two 'UniqFm's contain the same keys. equalKeysUFM :: UniqFM a -> UniqFM b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = Mon.getAll $ getConst $ - M.mergeA (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.traverseMissing (\_ _ -> Const (Mon.All False))) - (M.zipWithAMatched (\_ _ _ -> Const (Mon.All True))) m1 m2 +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 -- Instances |