[project @ 1998-04-07 07:51:07 by simonpj]

Simons changes while away at Tic/WG2.8

4 files changed, 89 insertions, 50 deletions

diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 16b84fefb2..106fe29c6f 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -24,6 +24,7 @@ import Stix		( StixTree )
 import Unique		( mkBuiltinUnique )
 import Util		( mapAccumB, panic )
 import GlaExts		( trace )
+import Outputable
 \end{code}
 
 This is the generic register allocator.
@@ -77,16 +78,18 @@ simpleRegAlloc
 simpleRegAlloc _ _ _ [] = Just []
 
 simpleRegAlloc free live env (instr:instrs)
-  = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then
-	Just (instr3 : instrs3)
-    else
-	Nothing
+ | null deadSrcs        && 
+   maybeToBool newAlloc && 
+   maybeToBool instrs2 
+ = Just (instr3 : instrs3)
+ | otherwise
+ = Nothing
   where
     instr3 = patchRegs instr (lookup env2)
 
-    (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) }
+    (srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d)
 
-    lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x}
+    lookup env x = case lookupFM env x of Just y -> y; Nothing -> x
 
     deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live]
     newDsts  = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env]
@@ -108,14 +111,14 @@ simpleRegAlloc free live env (instr:instrs)
 
     allocateNewReg _ Nothing = Nothing
 
-    allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) =
-	if null choices then Nothing
-	else Just (free2, prs2)
+    allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs))
+      | null choices = Nothing
+      | otherwise    = Just (free2, prs2)
       where
 	choices = possibleMRegs pk free
-	reg = head choices
-	free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
-	prs2 = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
+	reg     = head choices
+	free2   = free `useMReg` (case reg of {IBOX(reg2) -> reg2} )
+	prs2    = ((d,  MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs)
 \end{code}
 
 Here is the ``clever'' bit. First go backward (i.e. left), looking for
@@ -129,15 +132,20 @@ hairyRegAlloc
     -> [Instr]
     -> [Instr]
 
-hairyRegAlloc regs reserve_regs instrs
-  = case mapAccumB (doRegAlloc reserve_regs)
-	    (RH regs' 1 emptyFM) noFuture instrs
-    of (RH _ loc' _, _, instrs') ->
-	if loc' == 1 then instrs' else
-	case mapAccumB do_RegAlloc_Nil
-		(RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs'))
-	of ((RH _ loc'' _),_,instrs'') ->
-	    if loc'' == loc' then instrs'' else panic "runRegAllocate"
+hairyRegAlloc regs reserve_regs instrs =
+  case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of 
+   (RH _ mloc1 _, _, instrs')
+     | mloc1 == 1 -> instrs'
+     | otherwise  ->
+      let
+       instrs_patched' = patchMem instrs'
+       instrs_patched  = flattenOrdList instrs_patched'
+      in
+      case mapAccumB do_RegAlloc_Nil (RH regs'' mloc1 emptyFM) noFuture instrs_patched of
+	 ((RH _ mloc2 _),_,instrs'') 
+	    | mloc2 == mloc1 -> instrs'' 
+            | otherwise      -> instrs''
+	       --pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1)
   where
     regs'  = regs `useMRegs` reserve_regs
     regs'' = mkMRegsState reserve_regs
@@ -169,11 +177,12 @@ patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs
 patchMem' :: Instr -> InstrList
 
 patchMem' instr
-  = if null memSrcs && null memDsts then mkUnitList instr
-    else mkSeqList
-	    (foldr mkParList mkEmptyList loadSrcs)
-	    (mkSeqList instr'
-		(foldr mkParList mkEmptyList spillDsts))
+ | null memSrcs && null memDsts = mkUnitList instr
+ | otherwise =
+    mkSeqList
+      (foldr mkParList mkEmptyList loadSrcs)
+      (mkSeqList instr'
+	         (foldr mkParList mkEmptyList spillDsts))
 
     where
 	(RU srcs dsts) = regUsage instr
@@ -221,18 +230,26 @@ getUsage (RF next_in_use future reg_conflicts) instr
 	       live_through = in_use `minusRegSet` dsts
 	       last_used = [ r | r <- regSetToList srcs,
 			     not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)]
+
 	       in_use' = srcs `unionRegSets` live_through
-	       reg_conflicts' = case new_conflicts of
-		    [] -> reg_conflicts
-		    _ -> addListToFM reg_conflicts new_conflicts
-	       new_conflicts = if isEmptyRegSet live_dynamics then []
-			       else [ (r, merge_conflicts r)
-					| r <- extractMappedRegNos (regSetToList dsts) ]
-	       merge_conflicts reg = case lookupFM reg_conflicts reg of
-			    Nothing -> live_dynamics
-			    Just conflicts -> conflicts `unionRegSets` live_dynamics
-	       live_dynamics = mkRegSet
-			    [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
+
+	       reg_conflicts' = 
+	        case new_conflicts of
+		  [] -> reg_conflicts
+		  _  -> addListToFM reg_conflicts new_conflicts
+
+	       new_conflicts
+	        | isEmptyRegSet live_dynamics = []
+		| otherwise =
+		  [ (r, merge_conflicts r)
+		  | r <- extractMappedRegNos (regSetToList dsts) ]
+
+	       merge_conflicts reg = 
+	        case lookupFM reg_conflicts reg of
+		  Nothing        -> live_dynamics
+		  Just conflicts -> conflicts `unionRegSets` live_dynamics
+
+	       live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ]
 
 doRegAlloc'
     :: [RegNo]
@@ -273,18 +290,23 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst
 	    Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn
       dynToStatic other = other
 
-      allocateNewRegs
-	:: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)])
+      allocateNewRegs :: Reg 
+                      -> (MRegsState, Int, [(Reg, Reg)]) 
+		      -> (MRegsState, Int, [(Reg, Reg)])
 
       allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst)
-	where (fs', f, mem') = case acceptable fs of
-		[] -> (fs, MemoryReg mem pk, mem + 1)
-		(IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
-
-	      acceptable regs = filter no_conflict (possibleMRegs pk regs)
-	      no_conflict reg = case lookupFM conflicts reg of
-		    Nothing -> True
-		    Just conflicts -> not (d `elementOfRegSet` conflicts)
+	where 
+	 (fs', f, mem') = 
+	   case acceptable fs of
+	    []           -> (fs, MemoryReg mem pk, mem + 1)
+	    (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem)
+
+         acceptable regs = filter no_conflict (possibleMRegs pk regs)
+
+	 no_conflict reg = 
+	   case lookupFM conflicts reg of
+	     Nothing        -> True
+	     Just conflicts -> not (d `elementOfRegSet` conflicts)
 \end{code}
 
 We keep a local copy of the Prelude function \tr{notElem},
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 48412e9454..b9f66e88b6 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -1083,6 +1083,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
 		       where promote x = StPrim Float2DoubleOp [x]
       DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+--      _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
   where
     imul_div fn x y = getRegister (StCall fn IntRep [x, y])
 
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 37911bc47a..23c6a07f51 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -389,6 +389,7 @@ mpData_mantissa = mpData mantissa
 Support for the Gnu GMP multi-precision package.
 
 \begin{code}
+-- size (in words) of __MP_INT
 mpIntSize = 3 :: Int
 
 mpAlloc, mpSize, mpData :: StixTree -> StixTree
@@ -406,6 +407,7 @@ mpSpace gmp res sizes
   = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
   where
     sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
+    -- what's the magical 17 for?
     fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
     hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
 \end{code}
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 0df070d4e0..6b992e3fe7 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -7,6 +7,7 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
 
 #include "HsVersions.h"
 
+import Char	       ( ord )
 import MachMisc
 import MachRegs
 
@@ -28,9 +29,6 @@ import StixInteger	{- everything -}
 import UniqSupply	( returnUs, thenUs, UniqSM )
 import Outputable
 
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
 \end{code}
 
 The main honcho here is primCode, which handles the guts of COpStmts.
@@ -407,6 +405,22 @@ primCode [lhs] MakeStablePtrOp args
 \begin{code}
 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
 
+primCode [lhs] SeqOp [a]
+  = let
+     {-
+      The evaluation of seq#'s argument is done by `seqseqseq',
+      here we just set up the call to it (identical to how
+      DerefStablePtr does things.)
+     -}
+     lhs'   = amodeToStix lhs
+     a'     = amodeToStix a
+     pk     = getAmodeRep lhs  -- an IntRep
+     call   = StCall SLIT("SeqZhCode") pk [a']
+     assign = StAssign pk lhs' call
+    in
+--    trace "SeqOp" $ 
+    returnUs (\xs -> assign : xs)
+
 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
   | is_asm = error "ERROR: Native code generator can't handle casm"
   | otherwise