X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=109054fb9f621b1e1fc033c1e5d949cb6f975f85;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=875f790ae4b4fa418c7b76cd811116739c83385b;hpb=046ee54f048ddd721dcee41916d6a6f68db3b15b;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 875f790..109054f 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -245,7 +245,7 @@ cmmNativeGen dflags cmm
 sequenceTop :: NatCmmTop -> NatCmmTop
 sequenceTop top@(CmmData _ _) = top
 sequenceTop (CmmProc info lbl params blocks) = 
-  CmmProc info lbl params (sequenceBlocks blocks)
+  CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -289,6 +289,46 @@ reorder id accum (b@(block,id',out) : rest)
   | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
   | otherwise  = reorder id (b:accum) rest
 
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
+
+#if powerpc_TARGET_ARCH
+makeFarBranches blocks
+    | last blockAddresses < nearLimit = blocks
+    | otherwise = zipWith handleBlock blockAddresses blocks
+    where
+        blockAddresses = scanl (+) 0 $ map blockLen blocks
+        blockLen (BasicBlock _ instrs) = length instrs
+        
+        handleBlock addr (BasicBlock id instrs)
+                = BasicBlock id (zipWith makeFar [addr..] instrs)
+        
+        makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
+        makeFar addr (BCC cond tgt)
+            | abs (addr - targetAddr) >= nearLimit
+            = BCCFAR cond tgt
+            | otherwise
+            = BCC cond tgt
+            where Just targetAddr = lookupUFM blockAddressMap tgt
+        makeFar addr other            = other
+        
+        nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
+                         -- distance, as we have a few pseudo-insns that are
+                         -- pretty-printed as multiple instructions,
+                         -- and it's just not worth the effort to calculate
+                         -- things exactly
+        
+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
+#else
+makeFarBranches = id
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Instruction selection
 
@@ -444,33 +484,33 @@ cmmBlockConFold (BasicBlock id stmts) = do
 cmmStmtConFold stmt
    = case stmt of
         CmmAssign reg src
-           -> do src' <- cmmExprConFold False src
+           -> do src' <- cmmExprConFold DataReference src
                  return $ case src' of
 		   CmmReg reg' | reg == reg' -> CmmNop
 		   new_src -> CmmAssign reg new_src
 
         CmmStore addr src
-           -> do addr' <- cmmExprConFold False addr
-                 src'  <- cmmExprConFold False src
+           -> do addr' <- cmmExprConFold DataReference addr
+                 src'  <- cmmExprConFold DataReference src
                  return $ CmmStore addr' src'
 
         CmmJump addr regs
-           -> do addr' <- cmmExprConFold True addr
+           -> do addr' <- cmmExprConFold JumpReference addr
                  return $ CmmJump addr' regs
 
 	CmmCall target regs args vols
 	   -> do target' <- case target of
 			      CmmForeignCall e conv -> do
-			        e' <- cmmExprConFold True e
+			        e' <- cmmExprConFold CallReference e
 			        return $ CmmForeignCall e' conv
 			      other -> return other
                  args' <- mapM (\(arg, hint) -> do
-                                  arg' <- cmmExprConFold False arg
+                                  arg' <- cmmExprConFold DataReference arg
                                   return (arg', hint)) args
 	         return $ CmmCall target' regs args' vols
 
         CmmCondBranch test dest
-           -> do test' <- cmmExprConFold False test
+           -> do test' <- cmmExprConFold DataReference test
 	         return $ case test' of
 		   CmmLit (CmmInt 0 _) -> 
 		     CmmComment (mkFastString ("deleted: " ++ 
@@ -480,29 +520,29 @@ cmmStmtConFold stmt
 		   other -> CmmCondBranch test' dest
 
 	CmmSwitch expr ids
-	   -> do expr' <- cmmExprConFold False expr
+	   -> do expr' <- cmmExprConFold DataReference expr
 	         return $ CmmSwitch expr' ids
 
         other
            -> return other
 
 
-cmmExprConFold isJumpTarget expr
+cmmExprConFold referenceKind expr
    = case expr of
         CmmLoad addr rep
-           -> do addr' <- cmmExprConFold False addr
+           -> do addr' <- cmmExprConFold DataReference addr
                  return $ CmmLoad addr' rep
 
         CmmMachOp mop args
            -- For MachOps, we first optimize the children, and then we try 
            -- our hand at some constant-folding.
-           -> do args' <- mapM (cmmExprConFold False) args
+           -> do args' <- mapM (cmmExprConFold DataReference) args
                  return $ cmmMachOpFold mop args'
 
         CmmLit (CmmLabel lbl)
-           -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+           -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
-           -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+           -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
                  return $ cmmMachOpFold (MO_Add wordRep) [
                      dynRef,
                      (CmmLit $ CmmInt (fromIntegral off) wordRep)
@@ -514,11 +554,11 @@ cmmExprConFold isJumpTarget expr
            -- with the corresponding labels:
         CmmReg (CmmGlobal GCEnter1)
           | not opt_PIC
-          -> cmmExprConFold isJumpTarget $
+          -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
           | not opt_PIC
-          -> cmmExprConFold isJumpTarget $
+          -> cmmExprConFold referenceKind $
              CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
 #endif
 
@@ -533,12 +573,12 @@ cmmExprConFold isJumpTarget expr
                  Left  realreg -> return expr
                  Right baseRegAddr 
                     -> case mid of 
-                          BaseReg -> cmmExprConFold False baseRegAddr
-                          other   -> cmmExprConFold False (CmmLoad baseRegAddr 
-							(globalRegRep mid))
+                          BaseReg -> cmmExprConFold DataReference baseRegAddr
+                          other   -> cmmExprConFold DataReference
+                                        (CmmLoad baseRegAddr (globalRegRep mid))
 	   -- eliminate zero offsets
 	CmmRegOff reg 0
-	   -> cmmExprConFold False (CmmReg reg)
+	   -> cmmExprConFold referenceKind (CmmReg reg)
 
         CmmRegOff (CmmGlobal mid) offset
            -- RegOf leaves are just a shorthand form. If the reg maps
@@ -547,7 +587,7 @@ cmmExprConFold isJumpTarget expr
            -> case get_GlobalReg_reg_or_addr mid of
                 Left  realreg -> return expr
                 Right baseRegAddr
-                   -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
+                   -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
                                         CmmReg (CmmGlobal mid),
                                         CmmLit (CmmInt (fromIntegral offset)
                                                        wordRep)])