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

Simons changes while away at Tic/WG2.8

21 files changed, 240 insertions, 365 deletions

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 070cc7e380..cc5967df18 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -60,7 +60,12 @@ call to a cost evaluation function @GRAN_EXEC@. For that,
 
 \begin{code}
 writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC handle absC = printForC handle (pprAbsC absC (costs absC))
+--writeRealC handle absC = 
+-- _scc_ "writeRealC" 
+-- printDoc LeftMode handle (pprAbsC absC (costs absC))
+writeRealC handle absC = 
+ _scc_ "writeRealC" 
+ printForC handle (pprAbsC absC (costs absC))
 
 dumpRealC :: AbstractC -> SDoc
 dumpRealC absC = pprAbsC absC (costs absC)
@@ -77,19 +82,16 @@ emitMacro (Cost (i,b,l,s,f))
   = hcat [ ptext SLIT("GRAN_EXEC"), char '(',
                           int i, comma, int b, comma, int l, comma,
 	                  int s, comma, int f, pp_paren_semi ]
-\end{code}
 
-\begin{code}
 pp_paren_semi = text ");"
+\end{code}
 
--- ---------------------------------------------------------------------------
--- New type: Now pprAbsC also takes the costs for evaluating the Abstract C
--- code as an argument (that's needed when spitting out the GRAN_EXEC macro
--- which must be done before the return i.e. inside absC code)   HWL
--- ---------------------------------------------------------------------------
+New type: Now pprAbsC also takes the costs for evaluating the Abstract C
+code as an argument (that's needed when spitting out the GRAN_EXEC macro
+which must be done before the return i.e. inside absC code)   HWL
 
+\begin{code}
 pprAbsC :: AbstractC -> CostRes -> SDoc
-
 pprAbsC AbsCNop _ = empty
 pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c)
 
@@ -97,7 +99,6 @@ pprAbsC (CClosureUpdInfo info) c
   = pprAbsC info c
 
 pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src
-
 pprAbsC (CJump target) c
   = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++  CJump */"-} ])
 	     (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ])
@@ -199,9 +200,9 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _
     case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) ->
     if primOpNeedsWrapper op then
     	vcat [  pp_saves,
-    	    	    the_op,
-    	    	    pp_restores
-    	    	 ]
+    	    	the_op,
+    	    	pp_restores
+    	     ]
     else
     	the_op
     }
@@ -498,7 +499,6 @@ if_profiling pretty
   = if  opt_SccProfilingOn
     then pretty
     else char '0' -- leave it out!
-
 -- ---------------------------------------------------------------------------
 -- Changes for GrAnSim:
 --  draw costs for computation in head of if into both branches;
@@ -561,8 +561,8 @@ Some rough notes on generating code for @CCallOp@:
    (This happens after restoration of essential registers because we
    might need the @Base@ register to access all the others correctly.)
 
-{- Doesn't apply anymore with ForeignObj, structure create via primop.
-   makeForeignObj (ForeignObj is not CReturnable)
+{- Doesn't apply anymore with ForeignObj, structure created via the primop.
+   makeForeignObj (i.e., ForeignObj is not CReturnable)
 7) If returning Malloc Pointer, build a closure containing the
    appropriate value.
 -}
@@ -708,7 +708,7 @@ For l-values, the critical questions are:
 \begin{code}
 ppr_casm_results
 	:: [CAddrMode]	-- list of results (length <= 1)
-	-> SDoc	-- liveness mask
+	-> SDoc  	-- liveness mask
 	->
 	( SDoc,		-- declaration of any local vars
 	  [SDoc],	-- list of result vars (same length as results)
@@ -1138,6 +1138,7 @@ type CLabelSet = FiniteMap CLabel (){-any type will do-}
 emptyCLabelSet = emptyFM
 x `elementOfCLabelSet` labs
   = case (lookupFM labs x) of { Just _ -> True; Nothing -> False }
+
 addToCLabelSet set x = addToFM set x ()
 
 type TEenv = (UniqSet Unique, CLabelSet)
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index bb968a3e23..414ef2e663 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -258,15 +258,16 @@ mkRecordSelId field_label selector_ty
 	
     [data_id] = mkTemplateLocals [data_ty]
     alts      = map mk_maybe_alt data_cons
+    the_alts  = catMaybes alts
+
     sel_rhs   = mkTyLam tyvars $
 		mkValLam [data_id] $
 		Case (Var data_id) 
 		         -- if any of the constructors don't have the label, ...
 		     (if any (not . isJust) alts then
-		           AlgAlts (catMaybes alts) 
-			           (BindDefault data_id error_expr)
+		           AlgAlts the_alts(BindDefault data_id error_expr)
 		      else
-			   AlgAlts (catMaybes alts) NoDefault)
+			   AlgAlts the_alts NoDefault)
 
     mk_maybe_alt data_con 
 	  = case maybe_the_arg_id of
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 22a8556fb4..2a79917cf8 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -43,6 +43,7 @@ module Unique (
 	andandIdKey,
 	appendIdKey,
 	arrayPrimTyConKey,
+	assertIdKey,
 	augmentIdKey,
 	boolTyConKey,
 	boundedClassKey,
@@ -708,4 +709,5 @@ toEnumClassOpKey	= mkPreludeMiscIdUnique 68
 \begin{code}
 inlineIdKey		= mkPreludeMiscIdUnique 69
 coerceIdKey		= mkPreludeMiscIdUnique 70
+assertIdKey		= mkPreludeMiscIdUnique 71
 \end{code}
diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index 2eccc3e3e7..1d4edf00ee 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -502,13 +502,14 @@ constraints.
 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 simplify_eqns []                               = []
 simplify_eqns ((EqnInfo n ctx pats result):qs) = 
-    (EqnInfo n ctx(map simplify_pat pats) result) : 
-    simplify_eqns qs
+ (EqnInfo n ctx pats' result) : simplify_eqns qs
+ where
+  pats' = map simplify_pat pats
 
 simplify_pat :: TypecheckedPat -> TypecheckedPat  
-simplify_pat (WildPat gt ) = WildPat gt	
 
-simplify_pat (VarPat id)   = WildPat (idType id) 
+simplify_pat pat@(WildPat gt) = pat
+simplify_pat (VarPat id)      = WildPat (idType id) 
 
 simplify_pat (LazyPat p)   = simplify_pat p
 
@@ -535,11 +536,11 @@ simplify_pat (RecPat id ty idps) = ConPat id ty pats
                                    pats = map (\ (id,p,_)-> simplify_pat p) idps
 
 simplify_pat pat@(LitPat lit lit_ty) 
-  | isUnboxedType lit_ty = LitPat lit lit_ty
+  | isUnboxedType lit_ty = pat
 
   | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
 
-  | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
+  | otherwise = pat --pprPanic "tidy1:LitPat:" (ppr pat)
   where
     mk_char (HsChar c)    = HsCharPrim c
 
@@ -554,13 +555,20 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat
       | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
 
 		-- Convert the literal pattern "" to the constructor pattern [].
-      | null_str_lit lit       = ConPat nilDataCon    lit_ty [] 
+      | null_str_lit lit      = ConPat nilDataCon    lit_ty []
+      | one_str_lit lit       = ConPat consDataCon list_ty 
+                                   [ ConPat charDataCon   lit_ty [LitPat (mk_head_char lit) charPrimTy]
+				   , ConPat nilDataCon    lit_ty []]
 
       | otherwise	       = NPat lit lit_ty hsexpr
 
+    list_ty = mkListTy lit_ty
+
     mk_int    (HsInt i)      = HsIntPrim i
     mk_int    l@(HsLitLit s) = l
 
+    mk_head_char   (HsString s) = HsCharPrim (_HEAD_ s)
+
     mk_char   (HsChar c)     = HsCharPrim c
     mk_char   l@(HsLitLit s) = l
 
@@ -579,6 +587,9 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat
     null_str_lit (HsString s) = _NULL_ s
     null_str_lit other_lit    = False
 
+    one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
+    one_str_lit other_lit    = False
+
 simplify_pat (NPlusKPat	id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2 
      WildPat ty
    where ty = panic "Check.simplify_pat: Never used"
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index d7c3bdb4c1..a147fbfaa5 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -499,7 +499,9 @@ tidy1 v pat@(LitPat lit lit_ty) match_result
   = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy],
 	      match_result)
 
-  | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
+  | otherwise 
+  --= pprPanic "tidy1:LitPat:" (ppr pat)
+  = returnDs (pat, match_result)
   where
     mk_char (HsChar c)    = HsCharPrim c
 
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 4d16d00e43..5017e6cfe5 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -21,6 +21,7 @@ import DsMonad
 import DsUtils
 
 import Literal		( mkMachInt, Literal(..) )
+import PrimRep          ( PrimRep(IntRep) )
 import Maybes		( catMaybes )
 import Type		( Type, isUnpointedType )
 import Util		( panic, assertPanic )
@@ -72,8 +73,8 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t
 	mk_core_lit ty (HsStringPrim  s) = MachStr    s
 	mk_core_lit ty (HsFloatPrim   f) = MachFloat  f
 	mk_core_lit ty (HsDoublePrim  d) = MachDouble d
-	mk_core_lit ty (HsLitLit      s) = ASSERT(isUnpointedType ty)
-					   MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
+	mk_core_lit ty (HsLitLit      s) = --ASSERT(isUnpointedType ty)
+					   MachLitLit s IntRep -- (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
     	mk_core_lit ty other	         = panic "matchLiterals:mk_core_lit:unhandled"
 \end{code}
 
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 995a71975f..471b3c1d69 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -310,6 +310,7 @@ opt_IgnoreIfacePragmas		= lookUp  SLIT("-fignore-interface-pragmas")
 opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
 opt_MultiParamClasses		= opt_GlasgowExts
 opt_NoImplicitPrelude		= lookUp  SLIT("-fno-implicit-prelude")
+opt_NoHiCheck                   = lookUp  SLIT("-fno-hi-version-check")
 opt_NumbersStrict		= lookUp  SLIT("-fnumbers-strict")
 opt_OmitBlackHoling		= lookUp  SLIT("-dno-black-holing")
 opt_OmitInterfacePragmas	= lookUp  SLIT("-fomit-interface-pragmas")
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
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 780b9e16a6..d3025889de 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -964,6 +964,10 @@ dexp	:  MINUS kexp				{ $$ = mknegate($2); }
 	|  kexp
 	;
 
+/*
+  We need to factor out a leading let expression so we can set
+  inpat=TRUE when parsing (non let) expressions inside stmts and quals
+*/
 expLno 	: oexpLno DCOLON ctype			{ $$ = mkrestr($1,$3); }
 	| oexpLno
 	;
@@ -1172,7 +1176,7 @@ alts	:  alt					{ $$ = $1; }
 	|  alts SEMI alt			{ $$ = lconc($1,$3); }
 	;
 
-alt	:  pat { PREVPATT = $1; } altrest	{ $$ = lsing($3); PREVPATT = NULL; }
+alt	:  pat { PREVPATT = $1; } altrest	{ expORpat(LEGIT_PATT,$1); $$ = lsing($3); PREVPATT = NULL; }
 	|  /* empty */				{ $$ = Lnil; }
 	;
 
@@ -1578,6 +1582,16 @@ vccurly1:
 *                                                                     *
 **********************************************************************/
 
+
+/*
+void
+checkinpat()
+{
+  if(!inpat)
+    hsperror("pattern syntax used in expression");
+}
+*/
+
 /* The parser calls "hsperror" when it sees a
    `report this and die' error.  It sets the stage
    and calls "yyerror".
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 3e948ee3ef..692e675321 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -21,7 +21,7 @@ module PrelInfo (
 	ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, 
 	ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
 	and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
-	error_RDR, assert_RDR,
+	error_RDR, assertErr_RDR,
 	showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
 	showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
 
@@ -302,6 +302,7 @@ knownKeyNames
 
 	-- Others
     , (otherwiseId_RDR,		otherwiseIdKey)
+    , (assert_RDR,		assertIdKey)
     ]
 \end{code}
 
@@ -421,7 +422,8 @@ times_RDR	   = varQual (pREL_BASE, SLIT("*"))
 mkInt_RDR	   = varQual (pREL_BASE, SLIT("I#"))
 
 error_RDR	   = varQual (pREL_ERR, SLIT("error"))
-assert_RDR         = varQual (pREL_ERR, SLIT("assert__"))
+assert_RDR         = varQual (pREL_GHC, SLIT("assert"))
+assertErr_RDR       = varQual (pREL_ERR, SLIT("assertError"))
 
 eqH_Char_RDR	= prelude_primop CharEqOp
 ltH_Char_RDR	= prelude_primop CharLtOp
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 68b2609a40..7777049248 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -276,87 +276,37 @@ ifaceFlavour name = case getNameProvenance name of
 Looking up a name in the RnEnv.
 
 \begin{code}
-lookupRn :: RdrName
-	 -> Maybe Name		-- Result of environment lookup
-	 -> RnMS s Name
-lookupRn rdr_name (Just name)
-  = 	-- Found the name in the envt
-    returnRn name	-- In interface mode the only things in 
-			-- the environment are things in local (nested) scopes
-lookupRn rdr_name nm@Nothing
-  = tryLookupRn rdr_name nm `thenRn` \ name_or_error ->
-    case name_or_error of
-      Left (nm,err) -> failWithRn nm err
-      Right nm      -> returnRn nm
-
-tryLookupRn :: RdrName
-	    -> Maybe Name		-- Result of environment lookup
-	    -> RnMS s (Either (Name, ErrMsg) Name)
-tryLookupRn rdr_name (Just name) 
-  = 	-- Found the name in the envt
-    returnRn (Right name) -- In interface mode the only things in 
-			  -- the environment are things in local (nested) scopes
-
--- lookup in environment, but don't flag an error if
--- name is not found.
-tryLookupRn rdr_name Nothing
-  =	-- We didn't find the name in the environment
-    getModeRn 		`thenRn` \ mode ->
-    case mode of {
-	SourceMode -> returnRn (Left ( mkUnboundName rdr_name
-				     , unknownNameErr rdr_name));
-		-- Source mode; lookup failure is an error
-
-        InterfaceMode _ _ ->
-
-
-	----------------------------------------------------
-	-- OK, so we're in interface mode
-	-- An Unqual is allowed; interface files contain 
-	-- unqualified names for locally-defined things, such as
-	-- constructors of a data type.
-	-- So, qualify the unqualified name with the 
-	-- module of the interface file, and try again
-    case rdr_name of 
-	Unqual occ       -> 
-	    getModuleRn		`thenRn` \ mod ->
-            newImportedGlobalName mod occ HiFile `thenRn` \ nm ->
-	    returnRn (Right nm)
-	Qual mod occ hif -> 
-	    newImportedGlobalName mod occ hif `thenRn` \ nm ->
-	    returnRn (Right nm)
-
-    }
+lookupRn :: NameEnv -> RdrName -> RnMS s Name
+lookupRn name_env rdr_name
+  = case lookupFM name_env rdr_name of
+
+	-- Found it!
+	Just name -> returnRn name
+
+	-- Not found
+	Nothing -> getModeRn	`thenRn` \ mode ->
+		   case mode of 
+			-- Not found when processing source code; so fail
+			SourceMode    -> failWithRn (mkUnboundName rdr_name)
+					            (unknownNameErr rdr_name)
+		
+			-- Not found when processing an imported declaration,
+			-- so we create a new name for the purpose
+			InterfaceMode _ -> 
+			    case rdr_name of
+
+				Qual mod_name occ hif -> newGlobalName mod_name occ hif
+
+				-- An Unqual is allowed; interface files contain 
+				-- unqualified names for locally-defined things, such as
+				-- constructors of a data type.
+				Unqual occ -> getModuleRn 	`thenRn ` \ mod_name ->
+					      newGlobalName mod_name occ HiFile
+
 
 lookupBndrRn rdr_name
-  = lookupNameRn rdr_name		`thenRn` \ maybe_name ->
-    lookupRn rdr_name maybe_name	`thenRn` \ name ->
-
-    if isLocalName name then
-	returnRn name
-    else
-
-	----------------------------------------------------
-	-- OK, so we're at the binding site of a top-level defn
-	-- Check to see whether its an imported decl
-    getModeRn		`thenRn` \ mode ->
-    case mode of {
-	  SourceMode -> returnRn name ;
-
-	  InterfaceMode _ print_unqual_fn -> 
-
-	----------------------------------------------------
-	-- OK, the binding site of an *imported* defn
-	-- so we can make the provenance more informative
-    getSrcLocRn		`thenRn` \ src_loc ->
-    let
-	name' = case getNameProvenance name of
-		    NonLocalDef _ hif _ -> setNameProvenance name 
-						(NonLocalDef src_loc hif (print_unqual_fn name'))
-		    other		-> name
-    in
-    returnRn name'
-    }
+  = getNameEnv 			`thenRn` \ name_env ->
+    lookupRn name_env rdr_name
 
 -- Just like lookupRn except that we record the occurrence too
 -- Perhaps surprisingly, even wired-in names are recorded.
@@ -364,39 +314,18 @@ lookupBndrRn rdr_name
 -- deciding which instance declarations to import.
 lookupOccRn :: RdrName -> RnMS s Name
 lookupOccRn rdr_name
-  = tryLookupOccRn rdr_name `thenRn` \ name_or_error ->
-    case name_or_error of
-      Left (nm, err) -> failWithRn nm err
-      Right nm       -> returnRn nm
-
--- tryLookupOccRn is the fail-safe version of lookupOccRn, returning
--- back the error rather than immediately flagging it. It is only
--- directly used by RnExpr.rnExpr to catch and rewrite unbound
--- uses of `assert'.
-tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name)
-tryLookupOccRn rdr_name
-  = lookupNameRn rdr_name		`thenRn` \ maybe_name ->
-    tryLookupRn rdr_name maybe_name	`thenRn` \ name_or_error ->
-    case name_or_error of
-     Left _     -> returnRn name_or_error
-     Right name -> 
-       let
-	name' = mungePrintUnqual rdr_name name
-       in
-       addOccurrenceName name' `thenRn_`
-       returnRn name_or_error
-
+  = getNameEnv 			`thenRn` \ name_env ->
+    lookupRn name_env rdr_name	`thenRn` \ name ->
+    addOccurrenceName name
 
 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global 
--- environment only.  It's used for record field names only.
+-- environment.  It's used for record field names only.
 lookupGlobalOccRn :: RdrName -> RnMS s Name
 lookupGlobalOccRn rdr_name
-  = lookupGlobalNameRn rdr_name		`thenRn` \ maybe_name ->
-    lookupRn rdr_name maybe_name	`thenRn` \ name ->
-    let
-	name' = mungePrintUnqual rdr_name name
-    in
-    addOccurrenceName name'
+  = getGlobalNameEnv		`thenRn` \ name_env ->
+    lookupRn name_env rdr_name	`thenRn` \ name ->
+    addOccurrenceName name
+
 
 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified
 -- if they were mentioned unqualified in the source code.
@@ -619,7 +548,10 @@ filterAvail :: RdrNameIE	-- Wanted
 
 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
   | sub_names_ok = AvailTC n (filter is_wanted ns)
-  | otherwise    = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
+  | otherwise    = 
+#ifdef DEBUG
+		   pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $
+#endif
 		   NotAvailable
   where
     is_wanted name = nameOccName name `elem` wanted_occs
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 5d9092b330..f0ef83e872 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -30,7 +30,7 @@ import BasicTypes	( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
 import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
 			  ccallableClass_RDR, creturnableClass_RDR, 
 			  monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
-			  ratioDataCon_RDR, negate_RDR, assert_RDR,
+			  ratioDataCon_RDR, negate_RDR, assertErr_RDR,
 			  ioDataCon_RDR, ioOkDataCon_RDR
 			)
 import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
@@ -248,7 +248,7 @@ free-var set iff if it's a LocallyDefined Name.
 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 
 rnExpr (HsVar v)
-  = tryLookupOccRn v	`thenRn` \ res ->
+  = lookupOccRn v	`thenRn` \ name ->
     case res of
       Left (nm,err) 
         | opt_GlasgowExts && v == assertRdrName -> 
@@ -744,11 +744,8 @@ mkAssertExpr =
   returnRn (expr, name)
 
   where
-   mod = rdrNameModule assert_RDR
-   occ = rdrNameOcc assert_RDR
-
-assertRdrName :: RdrName
-assertRdrName = Unqual (VarOcc SLIT("assert"))
+   mod = rdrNameModule assertErr_RDR
+   occ = rdrNameOcc assertErr_RDR
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 0e80f1ea1b..99e34ab634 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -1,4 +1,4 @@
-`%
+%
 % (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[SimplCase]{Simplification of `case' expression}
@@ -37,6 +37,7 @@ import TyCon		( isDataTyCon )
 import TysPrim		( voidTy )
 import Util		( Eager, runEager, appEager,
 			  isIn, isSingleton, zipEqual, panic, assertPanic )
+import Outputable
 \end{code}
 
 Float let out of case.
@@ -685,7 +686,7 @@ completeAlgCaseWithKnownCon
 	-> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
 	-> SmplM OutExpr
 
-completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c
   = ASSERT(isDataCon con)
     search_alts alts
   where
@@ -709,7 +710,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
       = 	-- No matching alternative
 	case deflt of
 	  NoDefault 	 -> 	-- Blargh!
-	    panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+	    pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+	             (ppr con <+> ppr con_args $$ ppr a)
 
 	  BindDefault binder@(_,occ_info) rhs ->	-- OK, there's a default case
 			-- let-bind the binder to the constructor
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7bb409edff..f2d9c9396d 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -284,7 +284,6 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
 		-- 
 		-- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
 		-- real_tyvars_to_gen
-		--
     in
 
 	-- SIMPLIFY THE LIE
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 675a7924da..4f0d6eee79 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -265,27 +265,6 @@ tcCoreExpr (UfNote note expr)
 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 tcCoreNote UfInlineCall = returnTc InlineCall 
 \end{code}
-    returnTc (Note note' expr') 
-
-tcCoreExpr (UfLam bndr body)
-  = tcCoreLamBndr bndr 		$ \ bndr' ->
-    tcCoreExpr body		`thenTc` \ body' ->
-    returnTc (Lam bndr' body')
-
-tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
-  = tcCoreExpr rhs		`thenTc` \ rhs' ->
-    tcCoreValBndr bndr 		$ \ bndr' ->
-    tcCoreExpr body		`thenTc` \ body' ->
-    returnTc (Let (NonRec bndr' rhs') body')
-
-tcCoreExpr (UfLet (UfRec pairs) body)
-  = tcCoreValBndrs bndrs	$ \ bndrs' ->
-    mapTc tcCoreExpr rhss	`thenTc` \ rhss' ->
-    tcCoreExpr body		`thenTc` \ body' ->
-    returnTc (Let (Rec (bndrs' `zip` rhss')) body')
-  where
-    (bndrs, rhss) = unzip pairs
-\end{code}
 
 \begin{code}
 tcCoreLamBndr (UfValBinder name ty) thing_inside
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 1c1b1f00ff..d59e0d5ba3 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -431,13 +431,15 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 		-- mention the constructor, which doesn't exist for CCallable, CReturnable
 		-- Hardly beautiful, but only three extra lines.
 	   HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
-		 (HsLit (HsString (_PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas)))))
+		 (HsLitOut (HsString msg) stringTy)
 
 	  | otherwise	-- The common case
 	  = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
 			       (map HsVar (sc_dict_ids ++ meth_ids))
 		-- We don't produce a binding for the dict_constr; instead we
 		-- rely on the simplifier to unfold this saturated application
+	  where
+	    msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 
 	dict_bind    = VarMonoBind this_dict_id dict_rhs
 	method_binds = andMonoBinds method_binds_s
@@ -491,7 +493,7 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id
 
 	-- Warn if no method binding, only if -fwarn-missing-methods
     
-    warnTc (opt_WarnMissingMethods && 
+    warnTc (opt_WarnMissingMethods &&
 	    not (maybeToBool maybe_meth_bind) &&
 	    not (maybeToBool maybe_dm_id))	
 	(omittedMethodWarn sel_id clas)		`thenNF_Tc_`
@@ -532,143 +534,10 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id
 
 %************************************************************************
 %*									*
-\subsection{Type-checking specialise instance pragmas}
+\subsection{Checking for a decent instance type}
 %*									*
 %************************************************************************
 
-\begin{code}
-{- LATER
-tcSpecInstSigs :: E -> CE -> TCE
-	       -> Bag InstInfo		-- inst decls seen (declared and derived)
-	       -> [RenamedSpecInstSig]	-- specialise instance upragmas
-	       -> TcM (Bag InstInfo)	-- new, overlapped, inst decls
-
-tcSpecInstSigs e ce tce inst_infos []
-  = returnTc emptyBag
-
-tcSpecInstSigs e ce tce inst_infos sigs
-  = buildInstanceEnvs inst_infos 	`thenTc`    \ inst_mapper ->
-    tc_inst_spec_sigs inst_mapper sigs	`thenNF_Tc` \ spec_inst_infos ->
-    returnTc spec_inst_infos
-  where
-    tc_inst_spec_sigs inst_mapper []
-      = returnNF_Tc emptyBag
-    tc_inst_spec_sigs inst_mapper (sig:sigs)
-      = tcSpecInstSig e ce tce inst_infos inst_mapper sig	`thenNF_Tc` \ info_sig ->
-	tc_inst_spec_sigs inst_mapper sigs			`thenNF_Tc` \ info_sigs ->
-	returnNF_Tc (info_sig `unionBags` info_sigs)
-
-tcSpecInstSig :: E -> CE -> TCE
-	      -> Bag InstInfo
-	      -> InstanceMapper
-	      -> RenamedSpecInstSig
-	      -> NF_TcM (Bag InstInfo)
-
-tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
-  = recoverTc emptyBag			(
-    tcAddSrcLoc src_loc			(
-    let
-	clas = lookupCE ce class_name -- Renamer ensures this can't fail
-
-	-- Make some new type variables, named as in the specialised instance type
-	ty_names 			  = extractHsTyNames ???is_tyvarish_name??? ty
-	(tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
-    in
-    babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
-				`thenTc` \ inst_ty ->
-    let
-	maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
-			 Just (tc,_,_) -> Just tc
-			 Nothing       -> Nothing
-
-	maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
-    in
-	-- Check that we have a local instance declaration to specialise
-    checkMaybeTc maybe_unspec_inst
-	    (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
-
-	-- Create tvs to substitute for tmpls while simplifying the context
-    copyTyVars inst_tmpls	`thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
-    let
-	Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
-		       _ _ binds _ uprag) = maybe_unspec_inst
-
-    	subst = case matchTy unspec_inst_ty inst_ty of
-		     Just subst -> subst
-		     Nothing    -> panic "tcSpecInstSig:matchTy"
-
-	subst_theta    = instantiateThetaTy subst unspec_theta
-	subst_tv_theta = instantiateThetaTy tv_e subst_theta
-
-	mk_spec_origin clas ty
-	  = InstanceSpecOrigin inst_mapper clas ty src_loc
-	-- I'm VERY SUSPICIOUS ABOUT THIS
-	-- the inst-mapper is in a knot at this point so it's no good
-	-- looking at it in tcSimplify...
-    in
-    tcSimplifyThetas mk_spec_origin subst_tv_theta
-				`thenTc` \ simpl_tv_theta ->
-    let
-	simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
-
-	tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
-	tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
-    in
-    mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
-				`thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
-    getSwitchCheckerTc		`thenNF_Tc` \ sw_chkr ->
-    (if sw_chkr SpecialiseTrace then
-	pprTrace "Specialised Instance: "
-	(vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
-			  if null simpl_theta then empty else ptext SLIT("=>"),
-			  ppr clas,
-			  pprParendType inst_ty],
-		   hsep [ptext SLIT("        derived from:"),
-			  if null unspec_theta then empty else ppr unspec_theta,
-			  if null unspec_theta then empty else ptext SLIT("=>"),
-			  ppr clas,
-			  pprParendType unspec_inst_ty]])
-    else id) (
-
-    returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
-				dfun_theta dfun_id
-				binds src_loc uprag))
-    )))
-
-
-lookup_unspec_inst clas maybe_tycon inst_infos
-  = case filter (match_info match_inst_ty) (bagToList inst_infos) of
-	[]       -> Nothing
-	(info:_) -> Just info
-  where
-    match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
-      = from_here && clas == inst_clas &&
-	match_ty inst_ty && is_plain_instance inst_ty
-
-    match_inst_ty = case maybe_tycon of
-		      Just tycon -> match_tycon tycon
-		      Nothing    -> match_fun
-
-    match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
-	  Just (inst_tc,_,_) -> tycon == inst_tc
-	  Nothing            -> False
-
-    match_fun inst_ty = isFunType inst_ty
-
-
-is_plain_instance inst_ty
-  = case (splitAlgTyConApp_maybe inst_ty) of
-      Just (_,tys,_) -> all isTyVarTemplateTy tys
-      Nothing	     -> case maybeUnpackFunTy inst_ty of
-			  Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
-			  Nothing	  -> error "TcInstDecls:is_plain_instance"
--}
-\end{code}
-
-
-Checking for a decent instance type
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index e1155b0b2a..6195aea52e 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -36,7 +36,7 @@ import Type		( splitFunTys, splitRhoTy,
 import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
 			  doublePrimTy, addrPrimTy
 			)
-import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy )
+import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy, intTy )
 import Unique		( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
 import Util		( assertPanic, panic )
 import Outputable
@@ -295,7 +295,8 @@ tcPat (LitPatIn lit@(HsFrac f))
     origin = LiteralOrigin lit
 
 tcPat (LitPatIn lit@(HsLitLit s))
-  = error "tcPat: can't handle ``literal-literal'' patterns"
+--  = error "tcPat: can't handle ``literal-literal'' patterns"
+  = returnTc (LitPat lit intTy, emptyLIE, intTy)
 
 tcPat (NPlusKPatIn name lit@(HsInt i))
   = tcLookupLocalValueOK "tcPat1:n+k" name	`thenNF_Tc` \ local ->
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index c34404b2f8..fb73907943 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -280,10 +280,32 @@ pprCols = (100 :: Int) -- could make configurable
 printDoc :: Mode -> Handle -> Doc -> IO ()
 printDoc mode hdl doc
   = fullRender mode pprCols 1.5 put done doc
+{-
+  = _readHandle hdl				    >>= \ htype ->
+    let fp = _filePtr htype in
+    fullRender mode pprCols 1.5 (put (fp::_Addr)) (done fp) doc
+-}
   where
-    put (Chr c)  next = hPutChar hdl c >> next 
-    put (Str s)  next = hPutStr  hdl s >> next 
-    put (PStr s) next = hPutFS   hdl s >> next 
+{-
+    put fp (Chr c)  next = _scc_ "hPutChar" ((_ccall_ stg_putc c (fp::_Addr))::PrimIO ()) `seqPrimIO` next 
+    put fp (Str s)  next = _scc_ "hPutStr"  (put_str fp s)          >> next 
+    put fp (PStr s) next = _scc_ "hPutFS"   (put_str fp (_UNPK_ s)) >> next 
+
+    put_str fp (c1@(C# _) : cs)
+      = _ccall_ stg_putc  c1 (fp::_Addr)	`seqPrimIO`
+	put_str fp cs
+    put_str fp [] = return ()
+-}
+    put (Chr c)  next = _scc_ "hPutChar" (hPutChar hdl c) >> next 
+    put (Str s)  next = _scc_ "hPutStr"  (hPutStr  hdl s) >> next 
+    put (PStr s) next = _scc_ "hPutFS"   (hPutFS   hdl s) >> next 
+
+{-
+    string_txt (Chr c)   s2 = c   :  s2
+    string_txt (Str s1)  s2 = s1  ++ s2
+    string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2
+    done fp = ((_ccall_ stg_putc '\n' (fp::_Addr))::PrimIO ()) `seqPrimIO` return () --hPutChar hdl '\n'
+-}
 
     done = hPutChar hdl '\n'
 \end{code}