X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegisterAlloc.hs;h=bbab5180e7cc951f61dc1514f5d41d9e322f390b;hb=0d7c6cea4af4ac1137f40b8e35348744e80a23b9;hp=7d2ab1b6d63b2ada95c329dc43b0ff8794430bb2;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegisterAlloc.hs b/compiler/nativeGen/RegisterAlloc.hs
index 7d2ab1b..bbab518 100644
--- a/compiler/nativeGen/RegisterAlloc.hs
+++ b/compiler/nativeGen/RegisterAlloc.hs
@@ -510,13 +510,26 @@ raInsn block_live new_instrs (instr, r_dying, w_dying) = do
     -- register does not already have an assignment, then we can
     -- eliminate the instruction.
     case isRegRegMove instr of
-	Just (src,dst)
-		| src `elem` r_dying, 
-		  isVirtualReg dst,
-		  Just loc <- lookupUFM assig src,
-	 	  not (dst `elemUFM` assig) -> do
-			setAssigR (addToUFM (delFromUFM assig src) dst loc)
-			return (new_instrs, [])
+	Just (src,dst)	| src `elem` r_dying, 
+		  	  isVirtualReg dst,
+		 	  not (dst `elemUFM` assig) -> do
+	   case src of
+	      RealReg i -> setAssigR (addToUFM assig dst (InReg i))
+		-- if src is a fixed reg, then we just map dest to this
+		-- reg in the assignment.  src must be an allocatable reg,
+		-- otherwise it wouldn't be in r_dying.
+	      _virt -> case lookupUFM assig src of
+		         Nothing -> panic "raInsn"
+			 Just loc ->
+			   setAssigR (addToUFM (delFromUFM assig src) dst loc)
+
+	   -- we have elimianted this instruction
+	   {-
+	   freeregs <- getFreeRegsR
+    	   assig <- getAssigR
+	   pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+	   -}
+	   return (new_instrs, [])
 
 	other -> genRaInsn block_live new_instrs instr r_dying w_dying
 
@@ -848,42 +861,56 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 	       -- make sure that every temporary always gets its own
 	       -- stack slot.
 	       
-	       let graph = [ (loc0, loc0,
-	                       [lookupWithDefaultUFM_Directly
-                                    dest_assig
-                                    (panic "RegisterAlloc.joinToTargets")
-                                    vreg]
-                                    )
-	                   | (vreg, loc0) <- ufmToList adjusted_assig ]
+	       let graph = [ node | (vreg, src) <- ufmToList adjusted_assig,
+			     	    node <- mkNodes src vreg ]
+
 	           sccs = stronglyConnCompR graph
 	           
-	           handleComponent (CyclicSCC [one]) = []
-	           handleComponent (AcyclicSCC (src,_,[dst]))
-	               = makeMove src dst
+		   mkNodes src vreg = 
+			expandNode src (lookupWithDefaultUFM_Directly
+                                    	  dest_assig
+                                    	  (panic "RegisterAlloc.joinToTargets")
+                                    	  vreg)
+
+		-- The InBoth handling is a little tricky here.  If
+		-- the destination is InBoth, then we must ensure that
+		-- the value ends up in both locations.  An InBoth
+		-- destination must conflict with an InReg or InMem
+		-- source, so we expand an InBoth destination as
+		-- necessary.  An InBoth source is slightly different:
+		-- we only care about the register that the source value
+		-- is in, so that we can move it to the destinations.
+
+		   expandNode loc@(InReg src) (InBoth dst mem)
+			| src == dst = [(loc, loc, [InMem dst])]
+			| otherwise  = [(loc, loc, [InReg dst, InMem mem])]
+		   expandNode loc@(InMem src) (InBoth dst mem)
+			| src == mem = [(loc, loc, [InReg dst])]
+			| otherwise  = [(loc, loc, [InReg dst, InMem mem])]
+		   expandNode loc@(InBoth _ src) (InMem dst)
+			| src == dst = [] -- guaranteed to be true
+		   expandNode loc@(InBoth src _) (InReg dst)
+			| src == dst = []
+		   expandNode loc@(InBoth src _) dst
+			= expandNode (InReg src) dst
+		   expandNode src dst
+			| src == dst = []
+			| otherwise  = [(src, src, [dst])]
+
+		-- we have eliminated any possibility of single-node cylces
+		-- in expandNode above.
+	           handleComponent (AcyclicSCC (src,_,dsts))
+	               = map (makeMove src) dsts
 	           handleComponent (CyclicSCC things)
 	               = panic $ "Register Allocator: handleComponent: cyclic"
 	                         ++ " (workaround: use -fviaC)"
 	           
 	           makeMove (InReg src) (InReg dst)
-	               = [mkRegRegMoveInstr (RealReg src) (RealReg dst)]
+	               = mkRegRegMoveInstr (RealReg src) (RealReg dst)
 	     	   makeMove (InMem src) (InReg dst)
-	     	       = [mkLoadInstr (RealReg dst) delta src]
+	     	       = mkLoadInstr (RealReg dst) delta src
 	     	   makeMove (InReg src) (InMem dst)
-	     	       = [mkSpillInstr (RealReg src) delta dst]
-	     	   
-	     	   makeMove (InBoth src _) (InReg dst)
-	     	       | src == dst = []
-	     	   makeMove (InBoth _ src) (InMem dst)
-	     	       | src == dst = []
-	     	   makeMove (InBoth src _) dst
-	     	       = makeMove (InReg src) dst
-                   makeMove (InReg src) (InBoth dstR dstM)
-                       | src == dstR
-                       = makeMove (InReg src) (InMem dstM)
-                       | otherwise
-                       = makeMove (InReg src) (InReg dstR)
-                       ++ makeMove (InReg src) (InMem dstM)
-	     	   
+	     	       = mkSpillInstr (RealReg src) delta dst
 	     	   makeMove src dst
 	     	       = panic $ "makeMove (" ++ show src ++ ") ("
 	     	                 ++ show dst ++ ")"