- = {-# SCC "fixAssigns" #-}
- fixAssignsTop cmm `thenUs` \ fixed_cmm ->
- {-# SCC "genericOpt" #-}
- cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) ->
- (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
- then cmm
- else CmmData Text []) `bind` \ ppr_cmm ->
- {-# SCC "genMachCode" #-}
- genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
- {-# SCC "regAlloc" #-}
- mapUs regAlloc pre_regalloc `thenUs` \ with_regs ->
- {-# SCC "shortcutBranches" #-}
- shortcutBranches dflags with_regs `bind` \ shorted ->
- {-# SCC "sequenceBlocks" #-}
- map sequenceTop shorted `bind` \ sequenced ->
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced `bind` \ final_mach_code ->
- {-# SCC "vcat" #-}
- Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
-
- returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
- where
- x86fp_kludge :: NatCmmTop -> NatCmmTop
- x86fp_kludge top@(CmmData _ _) = top
+ = do
+ --
+ fixed_cmm
+ <- {-# SCC "fixAssigns" #-}
+ fixAssignsTop cmm
+
+ ---- cmm to cmm optimisations
+ (cmm, imports, ppr_cmm)
+ <- (\fixed_cmm
+ -> {-# SCC "genericOpt" #-}
+ do let (cmm, imports) = cmmToCmm dflags fixed_cmm
+
+ return ( cmm
+ , imports
+ , dchoose dflags Opt_D_dump_cmm cmm (CmmData Text []))
+ ) fixed_cmm
+
+
+ ---- generate native code from cmm
+ (native, lastMinuteImports, ppr_native)
+ <- (\cmm
+ -> {-# SCC "genMachCode" #-}
+ do (machCode, lastMinuteImports)
+ <- genMachCode dflags cmm
+
+ return ( machCode
+ , lastMinuteImports
+ , dchoose dflags Opt_D_dump_asm_native machCode [])
+ ) cmm
+
+
+ ---- tag instructions with register liveness information
+ (withLiveness, ppr_withLiveness)
+ <- (\native
+ -> {-# SCC "regLiveness" #-}
+ do
+ withLiveness <- mapUs regLiveness native
+
+ return ( withLiveness
+ , dchoose dflags Opt_D_dump_asm_liveness withLiveness []))
+ native
+
+ ---- allocate registers
+ (alloced, ppr_alloced, ppr_coalesce, ppr_regAllocStats, ppr_coloredGraph)
+ <- (\withLiveness
+ -> {-# SCC "regAlloc" #-}
+ do
+ 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
+ coalesced <- regCoalesce withLiveness
+
+ -- graph coloring register allocation
+ (alloced, regAllocStats)
+ <- Color.regAlloc
+ alloc_regs
+ (mkUniqSet [0..maxSpillSlots])
+ coalesced
+
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , dchoose dflags Opt_D_dump_asm_coalesce (Just coalesced) Nothing
+ , dchooses dflags
+ [ Opt_D_dump_asm_regalloc_stages
+ , Opt_D_drop_asm_stats]
+ (Just regAllocStats) Nothing
+ , dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing)
+
+ else do
+ -- do linear register allocation
+ alloced <- mapUs regAlloc withLiveness
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , Nothing
+ , Nothing
+ , Nothing ))
+ withLiveness
+
+
+ ---- shortcut branches
+ let shorted =
+ {-# SCC "shortcutBranches" #-}
+ shortcutBranches dflags alloced
+
+ ---- sequence blocks
+ let sequenced =
+ {-# SCC "sequenceBlocks" #-}
+ map sequenceTop shorted
+
+ ---- x86fp_kludge
+ let final_mach_code =