From: dias@eecs.harvard.edu Date: Fri, 17 Oct 2008 17:07:07 +0000 (+0000) Subject: Removed warnings, made Haddock happy, added examples in documentation X-Git-Tag: 2009-03-13~400 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6bc92166180824bf046d31e378359e3c386150f9 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. --- 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, [])