From 6bc92166180824bf046d31e378359e3c386150f9 Mon Sep 17 00:00:00 2001 From: "dias@eecs.harvard.edu" Date: Fri, 17 Oct 2008 17:07:07 +0000 Subject: [PATCH] Removed warnings, made Haddock happy, added examples in documentation The interesting examples talk about our story with heap checks in case alternatives and our story with the case scrutinee as a Boolean. --- compiler/cmm/CmmBuildInfoTables.hs | 48 ++++++++-------- compiler/cmm/CmmCPSZ.hs | 2 +- compiler/cmm/CmmCommonBlockElimZ.hs | 2 +- compiler/cmm/CmmCvt.hs | 2 +- compiler/cmm/CmmProcPointZ.hs | 12 ++-- compiler/cmm/CmmSpillReload.hs | 16 +++--- compiler/cmm/CmmStackLayout.hs | 8 +-- compiler/cmm/CmmUtils.hs | 2 +- compiler/cmm/MkZipCfg.hs | 2 +- compiler/cmm/OptimizationFuel.hs | 2 +- compiler/cmm/ZipCfgCmmRep.hs | 29 +++++++++- compiler/cmm/ZipDataflow.hs | 10 ++-- compiler/codeGen/StgCmmBind.hs | 19 +++---- compiler/codeGen/StgCmmExpr.hs | 103 +++++++++++++++++++++++++++++----- compiler/codeGen/StgCmmForeign.hs | 2 +- compiler/codeGen/StgCmmHeap.hs | 7 +-- compiler/codeGen/StgCmmLayout.hs | 3 - compiler/codeGen/StgCmmUtils.hs | 4 +- compiler/main/HscMain.lhs | 2 +- compiler/nativeGen/RegAllocLinear.hs | 6 +- 20 files changed, 186 insertions(+), 95 deletions(-) diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 173b799..e3d2ded 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -109,10 +109,10 @@ live_ptrs oldByte slotEnv areaMap bid = if off == w && widthInBytes (typeWidth ty) == w then (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst else panic "live_ptrs: only part of a variable live at a proc point" - add_slot rst (CallArea Old, off, w) = + add_slot rst (CallArea Old, _, _) = rst -- the update frame (or return infotable) should be live -- would be nice to check that only that part of the callarea is live... - add_slot rst c@((CallArea _), _, _) = + add_slot rst ((CallArea _), _, _) = rst -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT @@ -127,10 +127,10 @@ live_ptrs oldByte slotEnv areaMap bid = -- Construct the stack maps for the given procedure. setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables setInfoTableStackMap _ _ t@(NoInfoTable _) = t -setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable info bid updfr_off) = +setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) = updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t setInfoTableStackMap slotEnv areaMap - t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks)) + t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks)) procpoints) = case blockSetToList procpoints of [bid] -> @@ -250,9 +250,7 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t buildSRTs :: TopSRT -> FiniteMap CLabel CAFSet -> CAFSet -> FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT) buildSRTs topSRT topCAFMap cafs = - -- This is surely the wrong way to get names, as in BlockId - do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs - let liftCAF lbl () z = -- get CAFs for functions without static closures + do let liftCAF lbl () z = -- get CAFs for functions without static closures case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs Nothing -> addToFM z lbl () sub_srt topSRT localCafs = @@ -292,7 +290,7 @@ buildSRTs topSRT topCAFMap cafs = -- Adapted from simpleStg/SRT.lhs, which expects Id's. procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] -> FuelMonad (Maybe CmmTopZ, C_SRT) -procpointSRT top_srt top_table [] = +procpointSRT _ _ [] = return (Nothing, NoC_SRT) procpointSRT top_srt top_table entries = do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap @@ -331,7 +329,7 @@ to_SRT top_srt off len bmp -- Any procedure referring to a non-static CAF c must keep live the -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) -localCAFInfo _ t@(CmmData _ _) = Nothing +localCAFInfo _ (CmmData _ _) = Nothing localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) = case infoTbl of CmmInfoTable False _ _ _ -> @@ -382,12 +380,12 @@ bundleCAFs _ t@(NoInfoTable _) = (emptyFM, t) -- Construct the SRTs for the given procedure. setInfoTableSRT :: FiniteMap CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) -> FuelMonad (TopSRT, [CmmTopForInfoTables]) -setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable p procpoints)) = +setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) = case blockSetToList procpoints of - [bid] -> setSRT cafs topCAFMap topSRT t - _ -> panic "setInfoTableStackMap: unexpect number of procpoints" - -- until we stop splitting the graphs at procpoints in the native path -setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable info bid _)) = + [_] -> setSRT cafs topCAFMap topSRT t + _ -> panic "setInfoTableStackMap: unexpect number of procpoints" + -- until we stop splitting the graphs at procpoints in the native path +setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) = setSRT cafs topCAFMap topSRT t setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t]) @@ -406,7 +404,7 @@ updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) = FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off -updInfo toVars toSrt (NoInfoTable _) = panic "can't update NoInfoTable" +updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable" updInfo _ _ _ = panic "unexpected arg to updInfo" updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo @@ -418,7 +416,7 @@ updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo)) (ThunkInfo c s) -> ThunkInfo c (toSrt s) (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s) (ContInfo v s) -> ContInfo (toVars v) (toSrt s) -updInfoTbl toVars toSrt t@(CmmInfo _ _ CmmNonInfoTable) = t +updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t -- Lower the CmmTopForInfoTables type down to good old CmmTopZ -- by emitting info tables as data where necessary. @@ -437,16 +435,16 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) = extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv) extendEnvsForSafeForeignCalls cafEnv slotEnv g = fold_blocks block (cafEnv, slotEnv) g - where block b@(Block _ _ t) z = + where block b z = tail ( bt_last_in cafTransfers (lookupFn cafEnv) l , bt_last_in liveSlotTransfers (lookupFn slotEnv) l) z head where (head, last) = goto_end (G.unzip b) l = case last of LastOther l -> l LastExit -> panic "extendEnvs lastExit" - tail lives z (ZFirst _ _) = z + tail _ z (ZFirst _ _) = z tail lives@(cafs, slots) (cafEnv, slotEnv) - (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) = + (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = let slots' = removeLiveSlotDefs slots m slotEnv' = extendBlockEnv slotEnv bid slots' cafEnv' = extendBlockEnv cafEnv bid cafs @@ -489,11 +487,9 @@ data SafeState = State { s_blocks :: BlockEnv CmmBlock , s_safeCalls :: [CmmTopForInfoTables]} lowerSafeForeignCalls - :: ProcPointSet -> [[CmmTopForInfoTables]] -> - CmmTopZ -> FuelMonad [[CmmTopForInfoTables]] -lowerSafeForeignCalls _ rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst -lowerSafeForeignCalls procpoints rst - t@(CmmProc info l args g@(LGraph entry off blocks)) = do + :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]] +lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst +lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do let init = return $ State emptyBlockEnv emptyBlockSet [] let block b@(Block bid _ _) z = do state@(State {s_pps = ppset, s_blocks = blocks}) <- z @@ -510,7 +506,7 @@ lowerSafeForeignCalls procpoints rst -- Check for foreign calls -- if none, then we can avoid copying the block. hasSafeForeignCall :: CmmBlock -> Bool hasSafeForeignCall (Block _ _ t) = tail t - where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) t) = True + where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True tail (ZTail _ t) = tail t tail (ZLast _) = False @@ -536,7 +532,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) -- to lower a safe foreign call to a sequence of unsafe calls. lowerSafeForeignCall :: SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last) -lowerSafeForeignCall state m@(MidForeignCall (Safe infotable updfr) _ _ _) tail = do +lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 03051f7..008fa5d 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -116,7 +116,7 @@ cpsTop hsc_env (CmmProc h l args g) = mapM (dump Opt_D_dump_cmmz "after splitting") gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs mbpprTrace "localCAFs" (ppr localCAFs) $ return () - gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs + gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs index df15845..c4d612e 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -111,7 +111,7 @@ hash_block (Block _ _ t) = hash_lit (CmmLabel _) = 119 -- ugh hash_lit (CmmLabelOff _ i) = cvt $ 199 + i hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i - hash_lit (CmmBlock id) = 191 -- ugh + hash_lit (CmmBlock _) = 191 -- ugh hash_lit (CmmHighStackMark) = cvt 313 hash_tgt (ForeignTarget e _) = hash_e e hash_tgt (PrimTarget _) = 31 -- lots of these diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 3484ed6..f3c05b8 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -44,7 +44,7 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss - mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) = + mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) = mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz <*> mkStmts ss where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 5eaac74..712461d 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -385,7 +385,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv -- Input invariant: A block should only be reachable from a single ProcPoint. splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ] -splitAtProcPoints entry_label callPPs procPoints procMap areaMap +splitAtProcPoints entry_label callPPs procPoints procMap _areaMap (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g@(LGraph entry e_off blocks)) = do -- Build a map from procpoints to the blocks they reach @@ -402,7 +402,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv graph' = extendBlockEnv graph bid b graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g - graphEnv <- return {- $ pprTrace "graphEnv" (ppr graphEnv_pre) -} graphEnv_pre + graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre -- Build a map from proc point BlockId to labels for their new procedures let add_label map pp = return $ addToFM map pp lbl where lbl = if pp == entry then entry_label else blockLbl pp @@ -459,7 +459,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre) graphEnv_pre - let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs = + let to_proc (bid, g) | elemBlockSet bid callPPs = if bid == entry then CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g else @@ -476,9 +476,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap compare (expectJust "block_order" $ lookupBlockEnv block_order bid) (expectJust "block_order" $ lookupBlockEnv block_order bid') procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv - return -- $ pprTrace "procLabels" (ppr procLabels) - -- $ pprTrace "splitting graphs" (ppr procs) - $ procs + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] ---------------------------------------------------------------- diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index dcbde33..be570f2 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -119,17 +119,17 @@ middleDualLiveness live m = lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive lastDualLiveness env l = last l where last (LastBranch id) = env id - last l@(LastCall tgt Nothing _ _) = changeRegs (gen l . kill l) empty - last l@(LastCall tgt (Just k) _ _) = + last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty + last l@(LastCall _ (Just k) _ _) = -- nothing can be live in registers at this point, unless safe foreign call let live = env k live_in = DualLive (on_stack live) (gen l emptyRegSet) in if isEmptyUniqSet (in_regs live) then live_in else pprTrace "Offending party:" (ppr k <+> ppr live) $ panic "live values in registers at call continuation" - last l@(LastCondBranch e t f) = + last l@(LastCondBranch _ t f) = changeRegs (gen l . kill l) $ dualUnion (env t) (env f) - last l@(LastSwitch e tbl) = changeRegs (gen l . kill l) $ dualUnionList $ + last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $ map env (catMaybes tbl) empty = fact_bot dualLiveLattice @@ -254,10 +254,10 @@ akill a live = foldRegsUsed deleteFromAvail live a middleAvail :: Middle -> AvailRegs -> AvailRegs middleAvail m = middle m where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m - middle' (MidComment {}) live = live - middle' (MidAssign lhs _expr) live = akill lhs live - middle' (MidStore {}) live = live - middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet + middle' (MidComment {}) live = live + middle' (MidAssign lhs _expr) live = akill lhs live + middle' (MidStore {}) live = live + middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)] diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 3518df8..17a819f 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -147,7 +147,7 @@ liveLastOut env l = case l of LastCall _ Nothing n _ -> add_area (CallArea Old) n out -- add outgoing args (includes upd frame) - LastCall _ (Just k) n (Just upd_n) -> + LastCall _ (Just k) n (Just _) -> add_area (CallArea Old) n (add_area (CallArea (Young k)) n out) LastCall _ (Just k) n Nothing -> add_area (CallArea (Young k)) n out @@ -286,7 +286,7 @@ allocSlotFrom ig areaSize from areaMap area = -- Note: The stack pointer only has to be younger than the youngest live stack slot -- at proc points. Otherwise, the stack pointer can point anywhere. layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap -layout procPoints env g@(LGraph _ entrySp _) = +layout procPoints env g = let builder = areaBuilder ig = (igraph builder env g, builder) env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" @@ -386,7 +386,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = middle spOff m = mapExpDeepMiddle (replSlot spOff) m last spOff l = mapExpDeepLast (replSlot spOff) l replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i)) - replSlot spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark + replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord)) replSlot _ e = e -- The block must establish the SP expected at each successsor. @@ -419,7 +419,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = maxSlot :: (Area -> Int) -> CmmGraph -> Int maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i - add z (a, i, w) = max z (slotOff a + i) + add z (a, i, _) = max z (slotOff a + i) ----------------------------------------------------------------------------- -- | Sanity check: stub pointers immediately after they die diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 841f65b..3057712 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -70,7 +70,7 @@ primRepForeignHint IntRep = SignedHint primRepForeignHint WordRep = NoHint primRepForeignHint Int64Rep = SignedHint primRepForeignHint Word64Rep = NoHint -primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg +primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index 332b464..59d50d5 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -310,7 +310,7 @@ withUnique ofU = AGraph f f' g outOfLine (AGraph f) = AGraph f' - where f' g@(Graph tail' blocks') = + where f' (Graph tail' blocks') = do Graph emptyEntrance blocks <- f emptyGraph note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance return $ Graph tail' (blocks `plusBlockEnv` blocks') diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 7de398a..a5d8fa3 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,5 +1,5 @@ module OptimizationFuel - ( OptimizationFuel , canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel + ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel , OptFuelState, initOptFuelState --, setTotalFuel , tankFilledTo, diffFuel , FuelConsumer diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index b289fdc..43e310c 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -64,7 +64,7 @@ data Middle | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is -- given by cmmExprType of the rhs. - | MidForeignCall -- A foreign call; + | MidForeignCall -- A foreign call; see Note [Foreign calls] ForeignSafety -- Is it a safe or unsafe call? MidCallTarget -- call target and convention CmmFormals -- zero or more results @@ -142,6 +142,33 @@ data ValueDirection = Arguments | Results -- Arguments go with procedure definitions, jumps, and arguments to calls -- Results go with returns and with results of calls. deriving Eq + +{- Note [Foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~ +A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*. +Unsafe ones are easy: think of them as a "fat machine instruction". + +Safe ones are trickier. A safe foreign call + r = f(x) +ultimately expands to + push "return address" -- Never used to return to; + -- just points an info table + save registers into TSO + call suspendThread + r = f(x) -- Make the call + call resumeThread + restore registers + pop "return address" +We cannot "lower" a safe foreign call to this sequence of Cmms, because +after we've saved Sp all the Cmm optimiser's assumptions are broken. +Furthermore, currently the smart Cmm constructors know the calling +conventions for Haskell, the garbage collector, etc, and "lower" them +so that a LastCall passes no parameters or results. But the smart +constructors do *not* (currently) know the foreign call conventions. + +For these reasons use MidForeignCall for all calls. The only annoying thing +is that a safe foreign call needs an info table. +-} ---------------------------------------------------------------------- ----- Splicing between blocks diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index 8811755..9b18c77 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -900,7 +900,7 @@ backward_rew check_maybe = back rewrite start g exit_fact fuel = let Graph entry blockenv = g blocks = reverse $ G.postorder_dfs_from blockenv entry - in do { (FP env in_fact _ _ _, _) <- -- don't drop the entry fact! + in do { (FP _ in_fact _ _ _, _) <- -- don't drop the entry fact! solve depth name start transfers rewrites g exit_fact fuel --; env <- getAllFacts -- ; my_trace "facts after solving" (ppr env) $ return () @@ -1070,11 +1070,11 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => m f a -> m f a subAnalysis' m = do { a <- subAnalysis $ - do { a <- m; facts <- getAllFacts + do { a <- m; -- facts <- getAllFacts ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $ return a } - ; facts <- getAllFacts + -- ; facts <- getAllFacts ; -- my_trace "in parent analysis facts are" (pprFacts facts) $ return a } - where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) + -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env + -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0467678..a78abc7 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -84,7 +84,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps []) -- Don't drop the non-void args until the closure info has been made - ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info + ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $ @@ -293,7 +293,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere -- (b) ignore Sequel from context; use empty Sequel -- And compile the body - closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args) + closureCodeBody False bndr closure_info cc (nonVoidIds args) (length args) body fv_details -- BUILD THE OBJECT @@ -361,7 +361,6 @@ closureCodeBody :: Bool -- whether this is a top-level binding -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure - -> C_SRT -> [NonVoid Id] -- incoming args to the closure -> Int -- arity, including void args -> StgExpr @@ -381,12 +380,12 @@ closureCodeBody :: Bool -- whether this is a top-level binding argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL -} -closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details +closureCodeBody top_lvl bndr cl_info cc args arity body fv_details | length args == 0 -- No args i.e. thunk = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $ - (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body) + (\ (node, _) -> thunkCode cl_info fv_details cc node arity body) -closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details +closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = ASSERT( length args > 0 ) do { -- Allocate the global ticky counter, -- and establish the ticky-counter @@ -407,7 +406,7 @@ closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details ; granYield arg_regs node_points -- Main payload - ; entryHeapCheck node arity arg_regs srt $ do + ; entryHeapCheck node arity arg_regs $ do { enterCostCentre cl_info cc body ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after* @@ -454,15 +453,15 @@ mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" ----------------------------------------- thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> - C_SRT -> LocalReg -> Int -> StgExpr -> FCode () -thunkCode cl_info fv_details cc srt node arity body + LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details cc node arity body = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) ; tickyEnterThunk cl_info ; ldvEnterClosure cl_info -- NB: Node always points when profiling ; granThunk node_points -- Heap overflow check - ; entryHeapCheck node arity [] srt $ do + ; entryHeapCheck node arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check whenC (blackHoleOnEntry cl_info && node_points) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index dac7d67..3b6aac9 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -115,10 +115,10 @@ cgLetNoEscapeRhs local_cc bndr rhs = ; return info } -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body) - = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) + = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) - = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args) + = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) -- For a constructor RHS we want to generate a single chunk of -- code which can be jumped to from many places, which will -- return the constructor. It's easy; just behave as if it @@ -129,17 +129,15 @@ cgLetNoEscapeClosure :: Id -- binder -> Maybe LocalReg -- Slot for saved current cost centre -> CostCentreStack -- XXX: *** NOT USED *** why not? - -> SRT -> [NonVoid Id] -- Args (as in \ args -> body) -> StgExpr -- Body (as in above) -> FCode CgIdInfo -cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body +cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do { arg_regs <- forkProc $ do { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args - ; c_srt <- getSRTInfo srt - ; altHeapCheck arg_regs c_srt (cgExpr body) + ; altHeapCheck arg_regs (cgExpr body) -- Using altHeapCheck just reduces -- instructions to save on stack ; return arg_regs } @@ -262,11 +260,14 @@ data GcPlan -- of the case alternative(s) into the upstream check ------------------------------------- +-- See Note [case on Bool] cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode () --- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] - -- | isBoolTy (idType bndr) - -- , isDeadBndr bndr - -- = +{- +cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] + | isBoolTy (idType bndr) + , isDeadBndr bndr + = +-} cgCase scrut bndr srt alt_type alts = do { up_hp_usg <- getVirtHp -- Upstream heap usage @@ -280,10 +281,10 @@ cgCase scrut bndr srt alt_type alts gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts ; mb_cc <- maybeSaveCostCentre simple_scrut - ; c_srt <- getSRTInfo srt ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc + -- JD: We need Note: [Better Alt Heap Checks] ; bindArgsToRegs ret_bndrs ; cgAlts gc_plan (NonVoid bndr) alt_type alts } @@ -402,9 +403,8 @@ cgAltRhss gc_plan bndr alts maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a maybeAltHeapCheck NoGcInAlts code = code -maybeAltHeapCheck (GcInAlts regs srt) code - = do { c_srt <- getSRTInfo srt - ; altHeapCheck regs c_srt code } +maybeAltHeapCheck (GcInAlts regs _) code + = altHeapCheck regs code ----------------------------------------------------------------------------- -- Tail calls @@ -482,4 +482,77 @@ cgTailCall fun_id fun_info args node_points = nodeMustPointToIt lf_info +{- Note [case on Bool] + ~~~~~~~~~~~~~~~~~~~ +A case on a Boolean value does two things: + 1. It looks up the Boolean in a closure table and assigns the + result to the binder. + 2. It branches to the True or False case through analysis + of the closure assigned to the binder. +But the indirection through the closure table is unnecessary +if the assignment to the binder will be dead code (use isDeadBndr). + +The following example illustrates how badly the code turns out: + STG: + case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 { + GHC.Bool.False -> // sbH8 dead + GHC.Bool.True -> // sbH8 dead + }; + Cmm: + _s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign + _ccsW::I64 = %MO_F_Le_W64(_s7Hx::F64, _s7HD::F64); // MidAssign + // emitReturn // MidComment + _sbH8::I64 = I64[ghczmprim_GHCziBool_Bool_closure_tbl + (_ccsW::I64 << 3)]; // MidAssign + _ccsX::I64 = _sbH8::I64 & 7; // MidAssign + if (_ccsX::I64 >= 2) goto ccsH; else goto ccsI; // LastCondBranch + +The assignments to _sbH8 and _ccsX are completely unnecessary. +Instead, we should branch based on the value of _ccsW. +-} +{- Note [Better Alt Heap Checks] +If two function calls can share a return point, then they will also +get the same info table. Therefore, it's worth our effort to make +those opportunities appear as frequently as possible. + +Here are a few examples of how it should work: + + STG: + case f x of + True -> + False -> + Cmm: + r = call f(x) returns to L; + L: + if r & 7 >= 2 goto L1 else goto L2; + L1: + if Hp > HpLim then + r = gc(r); + goto L; + + L2: + +Note that the code following both the call to f(x) and the code to gc(r) +should be the same, which will allow the common blockifier to discover +that they are the same. Therefore, both function calls will return to the same +block, and they will use the same info table. + +Here's an example of the Cmm code we want from a primOp. +The primOp doesn't produce an info table for us to reuse, but that's okay: +we should still generate the same code: + STG: + case f x of + 0 -> <0-case code -- including allocation> + _ -> + Cmm: + r = a +# b; + L: + if r == 0 then goto L1 else goto L2; + L1: + if Hp > HpLim then + r = gc(r); + goto L; + <0-case code -- including allocation> + L2: + +-} diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2a6b794..2735b69 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -117,7 +117,7 @@ emitForeignCall -- only RTS procedures do this -> FCode () emitForeignCall safety results target args _srt ret - | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do + | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs updfr_off <- getUpdFrameOff emit caller_save diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 3f803d1..7138579 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -337,11 +337,10 @@ These are used in the following circumstances entryHeapCheck :: LocalReg -- Function (closure environment) -> Int -- Arity -- not same as length args b/c of voids -> [LocalReg] -- Non-void args (empty for thunk) - -> C_SRT -> FCode () -> FCode () -entryHeapCheck fun arity args srt code +entryHeapCheck fun arity args code = do updfr_sz <- getUpdFrameOff heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive where @@ -381,8 +380,8 @@ entryHeapCheck fun arity args srt code gc_lbl_ptrs _ = Nothing -altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a -altHeapCheck regs srt code +altHeapCheck :: [LocalReg] -> FCode a -> FCode a +altHeapCheck regs code = do updfr_sz <- getUpdFrameOff heapCheck False (gc_call updfr_sz) code where diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 33fd3e8..74bac43 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -166,9 +166,6 @@ direct_call caller lbl arity args reps | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord - ; let srt = pprTrace "Urk! SRT for over-sat call" - (ppr lbl) NoC_SRT - -- XXX: what if rest_args contains static refs? ; withSequel (AssignTo [pap_id] True) (emitCall Native target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 057e559..4803f5f 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -883,10 +883,10 @@ getSRTInfo (SRTEntries {}) = panic "getSRTInfo" getSRTInfo (SRT off len bmp) | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] = do { id <- newUnique - ; top_srt <- getSRTLabel + -- ; top_srt <- getSRTLabel ; let srt_desc_lbl = mkLargeSRTLabel id -- JD: We're not constructing and emitting SRTs in the back end, - -- which renders this code wrong (and it now names a now-non-existent label). + -- which renders this code wrong (it now names a now-non-existent label). -- ; emitRODataLits srt_desc_lbl -- ( cmmLabelOffW top_srt off -- : mkWordCLit (fromIntegral len) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index bc2747a..f054d25 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -808,7 +808,7 @@ testCmmConversion hsc_env cmm = let zgraph = initUs_ us cvtm us <- mkSplitUniqSupply 'S' let topSRT = initUs_ us emptySRT - (topSRT, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph + (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to Cmm" diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 323e1ff..c67ce3e 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -432,10 +432,10 @@ raInsn block_live new_instrs (Instr instr (Just live)) Just loc -> setAssigR (addToUFM (delFromUFM assig src) dst loc) - -- we have elimianted this instruction - freeregs <- getFreeRegsR - assig <- getAssigR + -- we have eliminated this instruction {- + freeregs <- getFreeRegsR + assig <- getAssigR pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do -} return (new_instrs, []) -- 1.7.10.4