+ = do
+ -- do native code generation on all these cmm things
+ (us', result)
+ <- mapAccumLM (cmmNativeGen dflags) us
+ $ concat $ map add_split cmms
+
+ let (native, imports, mColorStats, mLinearStats)
+ = unzip4 result
+
+ -- dump global NCG stats for graph coloring allocator
+ (case concat $ catMaybes mColorStats of
+ [] -> return ()
+ stats -> do
+ -- build the global register conflict graph
+ let graphGlobal
+ = foldl Color.union Color.initGraph
+ $ [ Color.raGraph stat
+ | stat@Color.RegAllocStatsStart{} <- stats]
+
+ dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Color.pprStats stats graphGlobal
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_conflicts "Register conflict graph"
+ $ Color.dotGraph Color.regDotColor trivColorable
+ $ graphGlobal)
+
+
+ -- dump global NCG stats for linear allocator
+ (case catMaybes mLinearStats of
+ [] -> return ()
+ stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Linear.pprStats (concat native) (concat stats))
+
+ return $ makeAsmDoc (concat native) (concat imports)
+
+ where add_split (Cmm tops)
+ | dopt Opt_SplitObjs dflags = split_marker : tops
+ | otherwise = tops
+
+ split_marker = CmmProc [] mkSplitMarkerLabel [] []
+
+
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+-- Dumping the output of each stage along the way.
+-- Global conflict graph and NGC stats
+cmmNativeGen
+ :: DynFlags
+ -> UniqSupply
+ -> RawCmmTop
+ -> IO ( UniqSupply
+ , ( [NatCmmTop]
+ , [CLabel]
+ , Maybe [Color.RegAllocStats]
+ , Maybe [Linear.RegAllocStats]))
+
+cmmNativeGen dflags us cmm
+ = do
+ -- rewrite assignments to global regs
+ let (fixed_cmm, usFix) =
+ initUs us $ fixAssignsTop cmm
+
+ -- cmm to cmm optimisations
+ let (opt_cmm, imports) =
+ cmmToCmm dflags fixed_cmm
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmm $ Cmm [opt_cmm])
+
+
+ -- generate native code from cmm
+ let ((native, lastMinuteImports), usGen) =
+ initUs usFix $ genMachCode dflags opt_cmm
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "Native code"
+ (vcat $ map (docToSDoc . pprNatCmmTop) native)
+
+
+ -- tag instructions with register liveness information
+ let (withLiveness, usLive) =
+ initUs usGen $ mapUs regLiveness native
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_liveness "Liveness annotations added"
+ (vcat $ map ppr withLiveness)
+
+
+ -- allocate registers
+ (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
+ if dopt Opt_RegsGraph dflags
+ then do
+ -- the regs usable for allocation
+ let alloc_regs
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (regClass r) (unitUniqSet r))
+ emptyUFM
+ $ map RealReg allocatableRegs
+
+ -- aggressively coalesce moves between virtual regs
+ let (coalesced, usCoalesce)
+ = initUs usLive $ regCoalesce withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
+ (vcat $ map ppr coalesced)
+
+ -- if any of these dump flags are turned on we want to hang on to
+ -- intermediate structures in the allocator - otherwise ditch
+ -- them early so we don't end up creating space leaks.
+ let generateRegAllocStats = or
+ [ dopt Opt_D_dump_asm_regalloc_stages dflags
+ , dopt Opt_D_dump_asm_stats dflags
+ , dopt Opt_D_dump_asm_conflicts dflags ]
+
+ -- graph coloring register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = initUs usCoalesce
+ $ Color.regAlloc
+ generateRegAllocStats
+ alloc_regs
+ (mkUniqSet [0..maxSpillSlots])
+ coalesced
+
+ -- dump out what happened during register allocation
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+ (vcat $ map (\(stage, stats)
+ -> text "-- Stage " <> int stage
+ $$ ppr stats)
+ $ zip [0..] regAllocStats)
+
+ return ( alloced, usAlloc
+ , if dopt Opt_D_dump_asm_stats dflags
+ then Just regAllocStats else Nothing
+ , Nothing)
+
+ else do
+ -- do linear register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = initUs usLive
+ $ liftM unzip
+ $ mapUs Linear.regAlloc withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+
+ return ( alloced, usAlloc
+ , Nothing
+ , if dopt Opt_D_dump_asm_stats dflags
+ then Just (catMaybes regAllocStats) else Nothing)
+
+ ---- shortcut branches
+ let shorted =
+ {-# SCC "shortcutBranches" #-}
+ shortcutBranches dflags alloced
+
+ ---- sequence blocks
+ let sequenced =
+ {-# SCC "sequenceBlocks" #-}
+ map sequenceTop shorted
+
+ ---- x86fp_kludge
+ let final_mach_code =
+#if i386_TARGET_ARCH
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge sequenced
+#else
+ sequenced
+#endif
+
+ return ( usAlloc
+ , ( final_mach_code
+ , lastMinuteImports ++ imports
+ , ppr_raStatsColor
+ , ppr_raStatsLinear) )
+
+
+#if i386_TARGET_ARCH
+x86fp_kludge :: NatCmmTop -> NatCmmTop
+x86fp_kludge top@(CmmData _ _) = top
+x86fp_kludge top@(CmmProc info lbl params code) =
+ CmmProc info lbl params (map bb_i386_insert_ffrees code)
+ where
+ bb_i386_insert_ffrees (BasicBlock id instrs) =
+ BasicBlock id (i386_insert_ffrees instrs)
+#endif
+
+
+-- | Build assembler source file from native code and its imports.
+--
+makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc
+makeAsmDoc native imports
+ = Pretty.vcat (map pprNatCmmTop native)
+ Pretty.$$ (Pretty.text "")
+ Pretty.$$ dyld_stubs imports
+