Re: [GHC] #8199: Get rid of HEAP_ALLOCED

#8199: Get rid of HEAP_ALLOCED ----------------------------+---------------------------------------------- Reporter: ezyang | Owner: ezyang Type: feature | Status: new request | Milestone: 7.10.1 Priority: normal | Version: 7.7 Component: | Keywords: Compiler | Architecture: Unknown/Multiple Resolution: | Difficulty: Project (more than a week) Operating System: | Blocked By: 5435 Unknown/Multiple | Related Tickets: Type of failure: | None/Unknown | Test Case: | Blocking: | ----------------------------+---------------------------------------------- Comment (by ezyang): OK, here is the proposed approach. Since we won't have collected all the static closures in time to place them in the first `CmmGroup` (due to streaming), we merely have to change the convention so the *last* block contains the data that needs to be initialized. This might not be ideal for linker efficiency but it prevents a space leak. {{{ diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index e2a5a07..e9f5668 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -79,12 +79,6 @@ codeGen dflags this_mod data_tycons return a yield cmm - -- Note [codegen-split-init] the cmm_init block must come - -- FIRST. This is because when -split-objs is on we need to - -- combine this block with its initialisation routines; see - -- Note [pipeline-split-init]. - ; cg (mkModuleInit cost_centre_info this_mod hpc_info) - ; mapM_ (cg . cgTopBinding dflags) stg_binds -- Put datatype_stuff after code_stuff, because the @@ -99,6 +93,12 @@ codeGen dflags this_mod data_tycons mapM_ (cg . cgDataCon) (tyConDataCons tycon) ; mapM_ do_tycon data_tycons + + -- Note [codegen-split-init] the cmm_init block must come + -- FIRST. This is because when -split-objs is on we need to + -- combine this block with its initialisation routines; see + -- Note [pipeline-split-init]. + ; cg (mkModuleInit cost_centre_info this_mod hpc_info) } --------------------------------------------------------------- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 517ba6c..2f7b847 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1313,18 +1313,18 @@ runPhase (RealPhase SplitAs) _input_fn dflags -- initialisation routine. -- -- To that end, we make a DANGEROUS ASSUMPTION here: the data - -- that needs to be initialised is all in the FIRST split + -- that needs to be initialised is all in the LAST split -- object. See Note [codegen-split-init]. PipeState{maybe_stub_o} <- getPipeState case maybe_stub_o of Nothing -> return () Just stub_o -> liftIO $ do - tmp_split_1 <- newTempName dflags osuf - let split_1 = split_obj 1 - copyFile split_1 tmp_split_1 - removeFile split_1 - joinObjectFiles dflags [tmp_split_1, stub_o] split_1 + tmp_split_n <- newTempName dflags osuf + let split_n = split_obj n + copyFile split_n tmp_split_n + removeFile split_n + joinObjectFiles dflags [tmp_split_n, stub_o] split_n -- join them into a single .o file liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 26aca2a..97802b4 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1670,13 +1670,36 @@ showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " i_str = show i padded = replicate (length n_str - length i_str) ' ' ++ i_str +-- Slightly inefficient, in that it needs to lookahead in order to +-- determine if it needs to cat the closures on immediatel +deferStaticClosures :: Monad m => + Either CLabel Module + -> Stream m [GenCmmDecl CmmStatics info stmt] b + -> [GenCmmDecl CmmStatics info stmt] + -> [GenCmmDecl CmmStatics info stmt] + -> Stream m [GenCmmDecl CmmStatics info stmt] b +deferStaticClosures lbl_or_mod str prev !closures = Stream.Stream $ do + r <- Stream.runStream str + case r of + Left x -> do + let addLabel starts = mkDataLits StaticClosureInds (mkStaticClosureIndsLabel lbl_or_mod starts) [] + return (Right (addLabel True : closures ++ [addLabel False] ++ prev, Stream.Stream (return (Left x)))) + Right (next, str') -> do + let isStaticClosure (CmmData StaticClosures _) = True + isStaticClosure (CmmData StaticClosureInds _) = True + isStaticClosure _ = False + newClosures = filter isStaticClosure next + next' = filter (not . isStaticClosure) next + closures' = newClosures `seq` (closures ++ newClosures) + if null prev + then Stream.runStream (deferStaticClosures lbl_or_mod str' next' closures') + else return (Right (prev, deferStaticClosures lbl_or_mod str' next' closures')) + prepareStaticClosures :: Monad m => Either CLabel Module -> Stream m [GenCmmDecl CmmStatics info stmt] b -> ForeignStubs -> (Stream m [GenCmmDecl CmmStatics info stmt] b, ForeignStubs) prepareStaticClosures lbl_or_mod cmms0 foreign_stubs0 = - let cmms = addLabel True >> cmms0 >>= (\r -> addLabel False >> return r) - addLabel starts = - Stream.yield [mkDataLits StaticClosureInds (mkStaticClosureIndsLabel lbl_or_mod starts) []] + let cmms = deferStaticClosures lbl_or_mod cmms0 [] [] foreign_stubs = foreign_stubs0 `appendStubC` static_closure_inds_init tag = case lbl_or_mod of Left lbl -> text "cmm_" <> ppr lbl }}} -- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/8199#comment:25 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler