[GHC] #8199: Get rid of HEAP_ALLOCED

[GHC]

#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