X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegisterAlloc.hs;h=8f7a6564ba31405259dd80394c39c71a14ad26c4;hp=20f7b61284f4d7af1043851c32ef20d8e4d9e592;hb=64f0661e56ca19214aed9c917612aeaa125253c6;hpb=57a4597d5a487af65d0a6c9a6701e2efcbbefac2

diff --git a/compiler/nativeGen/RegisterAlloc.hs b/compiler/nativeGen/RegisterAlloc.hs
index 20f7b61..8f7a656 100644
--- a/compiler/nativeGen/RegisterAlloc.hs
+++ b/compiler/nativeGen/RegisterAlloc.hs
@@ -901,11 +901,31 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 		-- we have eliminated any possibility of single-node cylces
 		-- in expandNode above.
 	           handleComponent (AcyclicSCC (vreg,src,dsts))
-	               = map (makeMove vreg src) dsts
-	           handleComponent (CyclicSCC things)
-	               = panic $ "Register Allocator: handleComponent: cyclic"
-	                         ++ " (workaround: use -fviaC)"
-	           
+	               = return $ map (makeMove vreg src) dsts
+
+		-- we can not have cycles that involve memory
+		-- locations as source nor as single destination
+		-- because memory locations (stack slots) are
+		-- allocated exclusively for a virtual register and
+		-- therefore can not require a fixup
+	           handleComponent (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
+	               = do
+		           spill_id <- getUniqueR
+		           (saveInstr,slot) <- spillR (RealReg sreg) spill_id
+			   remainingFixUps <- mapM handleComponent (stronglyConnCompR rest)
+			   restoreAndFixInstr <- getRestoreMoves dsts slot
+			   return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
+			 where
+			   getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
+			     = do
+				 restoreToReg <- loadR (RealReg reg) slot
+				 return $ [restoreToReg, makeMove vreg r mem]
+			   getRestoreMoves [InReg reg] slot
+			     = loadR (RealReg reg) slot >>= return . (:[])
+			   getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores"
+			   getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
+	           handleComponent (CyclicSCC _)
+		       = panic "Register Allocator: handleComponent cyclic"
 	           makeMove vreg (InReg src) (InReg dst)
 	               = mkRegRegMoveInstr (RealReg src) (RealReg dst)
 	     	   makeMove vreg (InMem src) (InReg dst)
@@ -918,8 +938,9 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 	                         ++ " (workaround: use -fviaC)"
 	     
 	       block_id <- getUniqueR
+	       fixUpInstrs <- mapM handleComponent sccs
 	       let block = BasicBlock (BlockId block_id) $
-	               concatMap handleComponent sccs ++ mkBranchInstr dest
+	               concat fixUpInstrs ++ mkBranchInstr dest
 	       let instr' = patchJump instr dest (BlockId block_id)
 	       joinToTargets block_live (block : new_blocks) instr' dests
   where