Some alpha renaming
[ghc.git] / compiler / nativeGen / AsmCodeGen.lhs
index 7c7d20c..a233a8f 100644 (file)
@@ -51,7 +51,7 @@ import NCGMonad
 import BlockId
 import CgUtils          ( fixStgRegisters )
 import OldCmm
-import CmmOpt           ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import CmmOpt           ( cmmMachOpFold )
 import OldPprCmm
 import CLabel
 
@@ -133,7 +133,7 @@ The machine-dependent bits break down as follows:
 
 data NcgImpl statics instr jumpDest = NcgImpl {
     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
-    generateJumpTableForInstr :: DynFlags -> instr -> Maybe (NatCmmDecl statics instr),
+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
     canShortcut               :: instr -> Maybe jumpDest,
     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
@@ -143,6 +143,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     allocatableRegs           :: [RealReg],
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
     ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
     }
 
@@ -154,15 +155,16 @@ nativeCodeGen dflags h us cmms
        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
-                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
                         ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
                         ,canShortcut               = X86.Instr.canShortcut
                         ,shortcutStatics           = X86.Instr.shortcutStatics
                         ,shortcutJump              = X86.Instr.shortcutJump
                         ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
-                        ,maxSpillSlots             = X86.Instr.maxSpillSlots (target32Bit platform)
-                        ,allocatableRegs           = X86.Regs.allocatableRegs
+                        ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags
+                        ,allocatableRegs           = X86.Regs.allocatableRegs platform
                         ,ncg_x86fp_kludge          = id
+                        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
                         ,ncgExpandTop              = id
                         ,ncgMakeFarBranches        = id
                     }
@@ -172,30 +174,32 @@ nativeCodeGen dflags h us cmms
                  ArchPPC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
                          ,canShortcut               = PPC.RegInfo.canShortcut
                          ,shortcutStatics           = PPC.RegInfo.shortcutStatics
                          ,shortcutJump              = PPC.RegInfo.shortcutJump
                          ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
-                         ,allocatableRegs           = PPC.Regs.allocatableRegs
+                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags
+                         ,allocatableRegs           = PPC.Regs.allocatableRegs platform
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = id
                          ,ncgMakeFarBranches        = makeFarBranches
                      }
                  ArchSPARC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
                          ,canShortcut               = SPARC.ShortcutJump.canShortcut
                          ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
                          ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
                          ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
+                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags
                          ,allocatableRegs           = SPARC.Regs.allocatableRegs
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                          ,ncgMakeFarBranches        = id
                      }
@@ -206,6 +210,23 @@ nativeCodeGen dflags h us cmms
                  ArchUnknown ->
                      panic "nativeCodeGen: No NCG for unknown arch"
 
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below.  To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+noAllocMoreStack amount _
+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+        ++  "   is a known limitation in the linear allocator.\n"
+        ++  "\n"
+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+        ++  "   You can still file a bug report if you like.\n"
+
+
 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
@@ -266,7 +287,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
         return  ()
 
  where  add_split tops
-                | dopt Opt_SplitObjs dflags = split_marker : tops
+                | gopt Opt_SplitObjs dflags = split_marker : tops
                 | otherwise                 = tops
 
         split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
@@ -335,8 +356,8 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
            -- and then using 'seq' doesn't work, because the let
            -- apparently gets inlined first.
         lsPprNative <- return $!
-                if  dopt Opt_D_dump_asm       dflags
-                 || dopt Opt_D_dump_asm_stats dflags
+                if  gopt Opt_D_dump_asm       dflags
+                 || gopt Opt_D_dump_asm_stats dflags
                         then native
                         else []
 
@@ -378,7 +399,7 @@ cmmNativeGen dflags ncgImpl us cmm count
         -- rewrite assignments to global regs
         let fixed_cmm =
                 {-# SCC "fixStgRegisters" #-}
-                fixStgRegisters platform cmm
+                fixStgRegisters dflags cmm
 
         -- cmm to cmm optimisations
         let (opt_cmm, imports) =
@@ -402,7 +423,7 @@ cmmNativeGen dflags ncgImpl us cmm count
         let (withLiveness, usLive) =
                 {-# SCC "regLiveness" #-}
                 initUs usGen
-                        $ mapM regLiveness
+                        $ mapM (regLiveness platform)
                         $ map natCmmTopToLive native
 
         dumpIfSet_dyn dflags
@@ -411,8 +432,8 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         -- allocate registers
         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
-         if ( dopt Opt_RegsGraph dflags
-           || dopt Opt_RegsIterative dflags)
+         if ( gopt Opt_RegsGraph dflags
+           || gopt Opt_RegsIterative dflags)
           then do
                 -- the regs usable for allocation
                 let (alloc_regs :: UniqFM (UniqSet RealReg))
@@ -445,7 +466,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                                 $ zip [0..] regAllocStats)
 
                 let mPprStats =
-                        if dopt Opt_D_dump_asm_stats dflags
+                        if gopt Opt_D_dump_asm_stats dflags
                          then Just regAllocStats else Nothing
 
                 -- force evaluation of the Maybe to avoid space leak
@@ -457,18 +478,27 @@ cmmNativeGen dflags ncgImpl us cmm count
 
           else do
                 -- do linear register allocation
+                let reg_alloc proc = do
+                       (alloced, maybe_more_stack, ra_stats) <-
+                               Linear.regAlloc dflags proc
+                       case maybe_more_stack of
+                         Nothing -> return ( alloced, ra_stats )
+                         Just amount ->
+                           return ( ncgAllocMoreStack ncgImpl amount alloced
+                                  , ra_stats )
+
                 let ((alloced, regAllocStats), usAlloc)
                         = {-# SCC "RegAlloc" #-}
                           initUs usLive
                           $ liftM unzip
-                          $ mapM (Linear.regAlloc dflags) withLiveness
+                          $ mapM reg_alloc withLiveness
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 let mPprStats =
-                        if dopt Opt_D_dump_asm_stats dflags
+                        if gopt Opt_D_dump_asm_stats dflags
                          then Just (catMaybes regAllocStats) else Nothing
 
                 -- force evaluation of the Maybe to avoid space leak
@@ -490,7 +520,7 @@ cmmNativeGen dflags ncgImpl us cmm count
         ---- generate jump tables
         let tabled      =
                 {-# SCC "generateJumpTables" #-}
-                generateJumpTables dflags ncgImpl kludged
+                generateJumpTables ncgImpl kludged
 
         ---- shortcut branches
         let shorted     =
@@ -711,12 +741,12 @@ makeFarBranches blocks
 -- Analyzes all native code and generates data sections for all jump
 -- table instructions.
 generateJumpTables
-        :: DynFlags -> NcgImpl statics instr jumpDest
-    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-generateJumpTables dflags ncgImpl xs = concatMap f xs
+        :: NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+generateJumpTables ncgImpl xs = concatMap f xs
     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
           f p = [p]
-          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl dflags) xs)
+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
 
 -- -----------------------------------------------------------------------------
 -- Shortcut branches
@@ -828,15 +858,13 @@ genMachCode dflags cmmTopCodeGen cmm_top
 Here we do:
 
   (a) Constant folding
-  (b) Simple inlining: a temporary which is assigned to and then
-      used, once, can be shorted.
   (c) Position independent code and dynamic linking
         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols
   (d) Some arch-specific optimizations
 
-(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
+(a) will be moving to the new Hoopl pipeline, however, (c) and
 (d) are only needed by the native backend and will continue to live
 here.
 
@@ -851,14 +879,7 @@ Ideas for other things we could do (put these in Hoopl please!):
 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-  let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks
-                       | otherwise = cmmEliminateDeadBlocks blocks
-      -- The new codegen path has already eliminated unreachable blocks by now
-
-      inlined_blocks | dopt Opt_TryNewCodeGen dflags = reachable_blocks
-                     | otherwise = cmmMiniInline dflags reachable_blocks
-
-  blocks' <- mapM cmmBlockConFold inlined_blocks
+  blocks' <- mapM cmmBlockConFold blocks
   return $ CmmProc info lbl (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@ -950,18 +971,19 @@ cmmStmtConFold stmt
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
 cmmExprConFold referenceKind expr = do
     dflags <- getDynFlags
-    -- Skip constant folding if new code generator is running
-    -- (this optimization is done in Hoopl)
-    -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off
-    let expr' = if False -- dopt Opt_TryNewCodeGen dflags
+
+    -- With -O1 and greater, the cmmSink pass does constant-folding, so
+    -- we don't need to do it again here.
+    let expr' = if optLevel dflags >= 1
                     then expr
-                    else cmmExprCon (targetPlatform dflags) expr
+                    else cmmExprCon dflags expr
+
     cmmExprNative referenceKind expr'
 
-cmmExprCon :: Platform -> CmmExpr -> CmmExpr
-cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
-cmmExprCon platform (CmmMachOp mop args)
-    = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
+cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
+cmmExprCon dflags (CmmMachOp mop args)
+    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
 cmmExprCon _ other = other
 
 -- handles both PIC and non-PIC cases... a very strange mixture
@@ -980,6 +1002,12 @@ cmmExprNative referenceKind expr = do
            -> do args' <- mapM (cmmExprNative DataReference) args
                  return $ CmmMachOp mop args'
 
+        CmmLit (CmmBlock id)
+           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+           -- we must convert block Ids to CLabels here, because we
+           -- might have to do the PIC transformation.  Hence we must
+           -- not modify BlockIds beyond this point.
+
         CmmLit (CmmLabel lbl)
            -> do
                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
@@ -987,24 +1015,24 @@ cmmExprNative referenceKind expr = do
            -> do
                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                  -- need to optimize here, since it's late
-                 return $ cmmMachOpFold platform (MO_Add wordWidth) [
+                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
                      dynRef,
-                     (CmmLit $ CmmInt (fromIntegral off) wordWidth)
+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
                    ]
 
         -- On powerpc (non-PIC), it's easier to jump directly to a label than
         -- to use the register table, so we replace these registers
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
-          | arch == ArchPPC && not (dopt Opt_PIC dflags)
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
-          | arch == ArchPPC && not (dopt Opt_PIC dflags)
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
         CmmReg (CmmGlobal GCFun)
-          | arch == ArchPPC && not (dopt Opt_PIC dflags)
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))