From: simonpj <unknown>
Date: Tue, 4 Jan 2000 17:40:52 +0000 (+0000)
Subject: [project @ 2000-01-04 17:40:46 by simonpj]
X-Git-Tag: Approximately_9120_patches~5355
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5ca77490a603e0175bb717343884533ad8de017d;p=ghc-hetmet.git

[project @ 2000-01-04 17:40:46 by simonpj]
This commit arranges that literal strings will fuse
nicely, by expressing them as an application of build.

* NoRepStr is now completely redundant, though I havn't removed it yet.

* The unpackStr stuff moves from PrelPack to PrelBase.

* There's a new form of Rule, a BuiltinRule, for rules that
  can't be expressed in Haskell.  The string-fusion rule is one
  such.  It's defined in prelude/PrelRules.lhs.

* PrelRules.lhs also contains a great deal of code that
  implements constant folding.  In due course this will replace
  ConFold.lhs, but for the moment it simply duplicates it.
---

diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES
index 2c0f82a..34931bd 100644
--- a/ghc/compiler/DEPEND-NOTES
+++ b/ghc/compiler/DEPEND-NOTES
@@ -1,75 +1,3 @@
-add types/InstEnv, InstEnv.hi-boot
-add coreSyn/CoreRules.*
-add coreSyn/CoreTidy.lhs
-add coreSyn/CoreFVs.lhs
-remove coreSyn/FreeVars.lhs
-add coreSyn/Subst.*
-remove simplCore/MagicUFs.*
-
-remove specialise/SpecEnv.*
-
-
-
-ToDo
-~~~~
-* Test effect of eta-expanding past (case x of ..)
-
-* Bottom strictness isn't right.  Should be (eg) SSX, not just X.
-
-* Enumeration types in worker/wrapper for strictness analysis
-
-* Use (!) types in data cons to unbox.
-
-* Check constant folding
-
-* .hi file isn't updated if the only change is to the exports.
-  For example, UgenAll.lhs re-exports all of U_binding.hs; when a data type
-  decl in the latter changes, the .hi file for the former isn't updated.
-  I think this happens when a module exports another mdodule thus:
-
-	module UgenAll( module U_binding, ... ) where
-
-* This should be reported as an error:
-	data T k = MkT (k Int#)
-
-* Bogus report of overlapped pattern for
-	f (R {field = [c]}) = 1
-  	f (R {})	      = 2
-  This shows up for TyCon.maybeTyConSingleCon
-
-*  > module Main( main ) where
-
-   > f :: String -> Int
-   > f "=<" = 0
-   > f "="  = 0
-   
-   > g :: [Char] -> Int
-   > g ['=','<'] = 0
-   > g ['=']     = 0
-   
-   > main = return ()
-   
-   For ``f'' the following is reported.
-   
-   tmp.lhs:4: 
-    Pattern match(es) are overlapped in the definition of function `f'
-            "=" = ...
-
-   There are no complaints for definition for ``g''.
-
-* Without -O I don't think we need change the module version
-  if the usages change; I forget why it changes even with -O
-
-* Record selectors for existential type; no good!  What to do?
-  Record update doesn't make sense either.
-
-  Need to be careful when figuring out strictness, and when generating
-  worker-wrapper split.
-
-  Also when deriving.
-
-* Consructor re-use via CSE
-
 		Notes on module dependencies
 		~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index d562a4d..54e776c 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -32,7 +32,7 @@ module Id (
 
 	isSpecPragmaId,	isRecordSelector,
 	isPrimitiveId_maybe, isDataConId_maybe,
-	isConstantId, isBottomingId, idAppIsBottom,
+	isConstantId, isConstantId_maybe, isBottomingId, idAppIsBottom,
 	isExportedId, isUserExportedId,
 	mayHaveNoBinding,
 
@@ -217,6 +217,10 @@ isConstantId id = case idFlavour id of
 		    ConstantId _ -> True
 		    other	 -> False
 
+isConstantId_maybe id = case idFlavour id of
+		  	  ConstantId const -> Just const
+			  other	           -> Nothing
+
 isSpecPragmaId id = case idFlavour id of
 			SpecPragmaId -> True
 			other	     -> False
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 878868f..e7b3b38 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -39,6 +39,8 @@ import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy,
 			)
 import TysWiredIn	( boolTy, charTy, mkListTy )
 import PrelMods		( pREL_ERR, pREL_GHC )
+import PrelRules	( primOpRule )
+import Rules		( addRule )
 import Type		( Type, ThetaType,
 			  mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
@@ -59,7 +61,7 @@ import Name		( mkDerivedName, mkWiredInIdName, mkLocalName,
 			  Name, NamedThing(..),
 			)
 import OccName		( mkSrcVarOcc )
-import PrimOp		( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import PrimOp		( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
 import Demand		( wwStrict )
 import DataCon		( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels, 
 			  dataConArgTys, dataConSig, dataConRawArgTys
@@ -70,7 +72,7 @@ import Id		( idType, mkId,
 			)
 import IdInfo		( vanillaIdInfo, mkIdInfo,
 			  exactArity, setUnfoldingInfo, setCafInfo,
-			  setArityInfo, setInlinePragInfo,
+			  setArityInfo, setInlinePragInfo, setSpecInfo,
 			  mkStrictnessInfo, setStrictnessInfo,
 			  IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
 			)
@@ -422,6 +424,20 @@ mkPrimitiveId prim_op
     info = mkIdInfo (ConstantId (PrimOp prim_op))
 	   `setUnfoldingInfo`	unfolding
 
+-- Not yet... 
+--	   `setSpecInfo`	rules
+--	   `setArityInfo` 	exactArity arity
+--	   `setStrictnessInfo`	strict_info
+
+    arity 		= primOpArity prim_op
+    (dmds, result_bot)	= primOpStrictness prim_op
+    strict_info		= mkStrictnessInfo (take arity dmds, result_bot)
+	-- primOpStrictness can return an infinite list of demands
+	-- (cheap hack) but Ids mustn't have such things.
+	-- What a mess.
+
+    rules = addRule id emptyCoreRules (primOpRule prim_op)
+
     unfolding = mkCompulsoryUnfolding rhs
 		-- The mkCompulsoryUnfolding says that this Id absolutely 
 		-- must be inlined.  It's only used for primitives, 
diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 32bb680..a6f39b3 100644
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -144,6 +144,7 @@ rulesSomeFreeVars interesting (Rules rules _)
   = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
 
 ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
+ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
 ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
   = rule_fvs interesting emptyVarSet
   where
@@ -151,6 +152,7 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
 	       foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
 
 ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
+ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
 ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
   = foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
 \end{code}
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 94aa741..80937db 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -11,7 +11,7 @@ module CoreSyn (
 
 	mkLets, mkLams,
 	mkApps, mkTyApps, mkValApps, mkVarApps,
-	mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
+	mkLit, mkStringLit, mkStringLitFS, mkConApp, mkPrimApp, mkNote,
 	bindNonRec, mkIfThenElse, varToCoreExpr,
 
 	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
@@ -34,6 +34,7 @@ module CoreSyn (
 	-- Core rules
 	CoreRules(..), 	-- Representation needed by friends
 	CoreRule(..),	-- CoreSubst, CoreTidy, CoreFVs, PprCore only
+	RuleName,
 	emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
     ) where
 
@@ -46,8 +47,9 @@ import VarEnv
 import Id		( mkWildId, getIdOccInfo, idInfo )
 import Type		( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
 import IdInfo		( OccInfo(..), megaSeqIdInfo )
-import Const	        ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
+import Const	        ( Con(..), DataCon, Literal(MachStr), mkMachInt, PrimOp )
 import TysWiredIn	( trueDataCon, falseDataCon )
+import ThinAir		( unpackCStringId, unpackCString2Id, addr2IntegerId )
 import VarSet
 import Outputable
 \end{code}
@@ -118,12 +120,18 @@ data CoreRules
   = Rules [CoreRule]
 	  IdOrTyVarSet		-- Locally-defined free vars of RHSs
 
+type RuleName = FAST_STRING
+
 data CoreRule
-  = Rule FAST_STRING	-- Rule name
+  = Rule RuleName
 	 [CoreBndr]	-- Forall'd variables
 	 [CoreExpr]	-- LHS args
 	 CoreExpr	-- RHS
 
+  | BuiltinRule		-- Built-in rules are used for constant folding
+			-- and suchlike.  It has no free variables.
+	([CoreExpr] -> Maybe (RuleName, CoreExpr))
+
 emptyCoreRules :: CoreRules
 emptyCoreRules = Rules [] emptyVarSet
 
@@ -184,16 +192,32 @@ mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 mkValApps f args = foldl (\ e a -> App e a)	   f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 
-mkLit       :: Literal -> Expr b
-mkStringLit :: String  -> Expr b
-mkConApp    :: DataCon -> [Arg b] -> Expr b
-mkPrimApp   :: PrimOp  -> [Arg b] -> Expr b
+mkLit         :: Literal -> Expr b
+mkStringLit   :: String  -> Expr b
+mkStringLitFS :: FAST_STRING  -> Expr b
+mkConApp      :: DataCon -> [Arg b] -> Expr b
+mkPrimApp     :: PrimOp  -> [Arg b] -> Expr b
 
 mkLit lit	  = Con (Literal lit) []
-mkStringLit str	  = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
 mkConApp con args = Con (DataCon con) args
 mkPrimApp op args = Con (PrimOp op)   args
 
+mkStringLit str	= mkStringLitFS (_PK_ str)
+
+mkStringLitFS str
+  | any is_NUL (_UNPK_ str)
+  = 	 -- Must cater for NULs in literal string
+    mkApps (Var unpackCString2Id)
+		[mkLit (MachStr str),
+		 mkLit (mkMachInt (toInteger (_LENGTH_ str)))]
+
+  | otherwise
+  =	-- No NULs in the string
+    App (Var unpackCStringId) (mkLit (MachStr str))
+
+  where
+    is_NUL c = c == '\0'
+
 varToCoreExpr :: CoreBndr -> CoreExpr
 varToCoreExpr v | isId v    = Var v
                 | otherwise = Type (mkTyVarTy v)
@@ -430,6 +454,7 @@ seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
 
 seq_rules [] = ()
 seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
+seq_rules (BuiltinRule _ : rules) = seq_rules rules
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index a980409..bdf688f 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -252,6 +252,7 @@ tidyRules env (Rules rules fvs)
     tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
 
 tidyRule :: TidyEnv -> CoreRule -> CoreRule
+tidyRule env rule@(BuiltinRule _) = rule
 tidyRule env (Rule name vars tpl_args rhs)
   = (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
   where
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index faa3983..b3495f3 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -49,7 +49,8 @@ import OccurAnal	( occurAnalyseGlobalExpr )
 import BinderInfo	( )
 import CoreUtils	( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap )
 import Id		( Id, idType, idUnique, isId, getIdWorkerInfo,
-			  getIdSpecialisation, getInlinePragma, getIdUnfolding
+			  getIdSpecialisation, getInlinePragma, getIdUnfolding,
+			  isConstantId_maybe
 			)
 import VarSet
 import Name		( isLocallyDefined )
@@ -277,7 +278,7 @@ sizeExpr :: Int 	    -- Bomb out if it gets bigger than this
 	 -> CoreExpr
 	 -> ExprSize
 
-sizeExpr (I# bOMB_OUT_SIZE) args expr
+sizeExpr (I# bOMB_OUT_SIZE) top_args expr
   = size_up expr
   where
     size_up (Type t)	      = sizeZero	-- Types cost nothing
@@ -288,7 +289,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
     size_up (App fun (Type t))  = size_up fun
     size_up (App fun arg)       = size_up_app fun [arg]
 
-    size_up (Con con args) = foldr (addSize . size_up) 
+    size_up (Con con args) = foldr (addSize . nukeScrutDiscount . size_up) 
 				   (size_up_con con args)
 				   args
 
@@ -324,16 +325,25 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
     ------------ 
     size_up_app (App fun arg) args   = size_up_app fun (arg:args)
     size_up_app fun 	      args   = foldr (addSize . nukeScrutDiscount . size_up) 
-					     (size_up_fun fun)
+					     (size_up_fun fun args)
 					     args
 
 	-- A function application with at least one value argument
 	-- so if the function is an argument give it an arg-discount
 	-- Also behave specially if the function is a build
-    size_up_fun (Var fun) | idUnique fun == buildIdKey   = buildSize
-    			  | idUnique fun == augmentIdKey = augmentSize
-    			  | fun `is_elem` args	 	 = scrutArg fun `addSize` sizeOne
-    size_up_fun other					 = size_up other
+	-- Also if the function is a constant Id (constr or primop)
+	-- compute discounts as if it were actually a Con; in the early
+	-- stages these constructors and primops may not yet be inlined
+    size_up_fun (Var fun) args | idUnique fun == buildIdKey   = buildSize
+    			       | idUnique fun == augmentIdKey = augmentSize
+    			       | fun `is_elem` top_args	      = scrutArg fun `addSize` fun_size
+			       | otherwise		      = fun_size
+			  where
+			    fun_size = case isConstantId_maybe fun of
+					     Just con -> size_up_con con args
+					     Nothing  -> sizeOne
+
+    size_up_fun other args = size_up other
 
     ------------ 
     size_up_alt (con, bndrs, rhs) = size_up rhs
@@ -353,8 +363,8 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
 		| otherwise 	     = opt_UF_DearOp
 
 	-- We want to record if we're case'ing, or applying, an argument
-    arg_discount (Var v) | v `is_elem` args = scrutArg v
-    arg_discount other			    = sizeZero
+    arg_discount (Var v) | v `is_elem` top_args = scrutArg v
+    arg_discount other			        = sizeZero
 
     ------------
     is_elem :: Id -> [Id] -> Bool
@@ -529,7 +539,11 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
   = case getIdUnfolding id of {
 	NoUnfolding -> Nothing ;
 	OtherCon _  -> Nothing ;
-	CompulsoryUnfolding unf_template -> Just unf_template ;
+	CompulsoryUnfolding unf_template | black_listed -> Nothing 
+					 | otherwise 	-> Just unf_template ;
+		-- Primops have compulsory unfoldings, but
+		-- may have rules, in which case they are 
+		-- black listed till later
 	CoreUnfolding unf_template is_top is_cheap _ guidance ->
 
     let
@@ -701,7 +715,7 @@ blackListed rule_vars (Just 0)
 			-- local inlinings first.  For example in fish/Main.hs
 			-- it's advantageous to inline scale_vec2 before inlining
 			-- wrappers from PrelNum that make it look big.
-	  not (isLocallyDefined v)	-- This seems best at the moment
+	  not (isLocallyDefined v) || normal_case rule_vars 0 v		-- This seems best at the moment
 
 blackListed rule_vars (Just phase)
   = \v -> normal_case rule_vars phase v
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 198b406..6ecd4a5 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -27,11 +27,12 @@ import Var		( IdOrTyVar, isId, isTyVar )
 import VarSet
 import VarEnv
 import Name		( isLocallyDefined, hashName )
-import Const		( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
-			  conType, conOkForSpeculation, conStrictness, hashCon
+import Const		( Con(..), isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
+			  conType, hashCon
 			)
+import PrimOp		( primOpOkForSpeculation, primOpStrictness )
 import Id		( Id, idType, setIdType, idUnique, idAppIsBottom,
-			  getIdArity, idName,
+			  getIdArity, idName, isPrimitiveId_maybe,
 			  getIdSpecialisation, setIdSpecialisation,
 			  getInlinePragma, setInlinePragma,
 			  getIdUnfolding, setIdUnfolding, idInfo
@@ -249,14 +250,32 @@ exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Var v)        	  = isUnLiftedType (idType v)
 exprOkForSpeculation (Note _ e)     	  = exprOkForSpeculation e
 
-exprOkForSpeculation (Con con args)
-  = conOkForSpeculation con &&
-    and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
+exprOkForSpeculation (Con (Literal _) args) = True
+exprOkForSpeculation (Con (DataCon _) args) = True
+	-- The strictness of the constructor has already
+	-- been expressed by its "wrapper", so we don't need
+	-- to take the arguments into account
+
+exprOkForSpeculation (Con (PrimOp op) args)
+  = prim_op_ok_for_spec op args
+
+exprOkForSpeculation (App fun arg)	-- Might be application of a primop
+  = go fun [arg]
   where
-    ok arg demand | isLazy demand = True
-		  | otherwise	  = exprOkForSpeculation arg
+    go (App fun arg) args = go fun (arg:args)
+    go (Var v) 	     args = case isPrimitiveId_maybe v of
+				Just op -> prim_op_ok_for_spec op args
+				Nothing -> False
+    go other args = False
 
 exprOkForSpeculation other = False	-- Conservative
+
+prim_op_ok_for_spec op args
+ = primOpOkForSpeculation op &&
+   and (zipWith ok (filter isValArg args) (fst (primOpStrictness op)))
+ where
+   ok arg demand | isLazy demand = True
+		  | otherwise	  = exprOkForSpeculation arg
 \end{code}
 
 
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 67bd8a4..92db05f 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -374,13 +374,16 @@ pprIfaceCoreRules :: CoreRules -> SDoc
 pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
 
 pprCoreRule :: Maybe Id -> CoreRule -> SDoc
+pprCoreRule maybe_fn (BuiltinRule _)
+  = ifPprDebug (ptext SLIT("A built in rule"))
+
 pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
   = doubleQuotes (ptext name) <+> 
     sep [
 	  ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 	  nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
 	  nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
-    ]
+    ] <+> semi
   where
     pp_fn = case maybe_fn of
 	    	Just id -> ppr id
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 02599cb..8f2d41f 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -526,6 +526,7 @@ substRules subst (Rules rules rhs_fvs)
     new_rules = Rules (map do_subst rules)
 		      (subst_fvs (substEnv subst) rhs_fvs)
 
+    do_subst rule@(BuiltinRule _) = rule
     do_subst (Rule name tpl_vars lhs_args rhs)
 	= Rule name tpl_vars' 
 	       (map (substExpr subst') lhs_args)
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index c1a2d6e..36eae0f 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -157,32 +157,11 @@ dsExpr (HsLitOut (HsString s) _)
 
 -- "_" => build (\ c n -> c 'c' n)	-- LATER
 
--- "str" ==> build (\ c n -> foldr charTy T c n "str")
-
-{- LATER:
-dsExpr (HsLitOut (HsString str) _)
-  = newTyVarsDs [alphaTyVar]		`thenDs` \ [new_tyvar] ->
-    let
- 	new_ty = mkTyVarTy new_tyvar
-    in
-    newSysLocalsDs [
-		charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
-		new_ty,
-		       mkForallTy [alphaTyVar]
-			       ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
-			       	        `mkFunTy` (alphaTy `mkFunTy` alphaTy))
-		]			`thenDs` \ [c,n,g] ->
-     returnDs (mkBuild charTy new_tyvar c n g (
-	foldl App
-	  (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
-   	  [VarArg c,VarArg n,LitArg (NoRepStr str)]))
--}
-
 -- otherwise, leave it as a NoRepStr;
 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
 
 dsExpr (HsLitOut (HsString str) _)
-  = returnDs (mkLit (NoRepStr str stringTy))
+  = returnDs (mkStringLitFS str)
 
 dsExpr (HsLitOut (HsLitLit str) ty)
   | isUnLiftedType ty
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 81aff83..9901853 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -212,10 +212,10 @@ ifaceRules if_hdl rules emitted
 	
 	return ()
   where
-    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule <+> semi
+    orphan_rule_pretties =  [ pprCoreRule (Just fn) rule
 			    | ProtoCoreRule _ fn rule <- rules
 			    ]
-    local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi
+    local_id_pretties = [ pprCoreRule (Just fn) rule
  		        | fn <- varSetElems emitted, 
 			  rule <- rulesRules (getIdSpecialisation fn),
 			  all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
new file mode 100644
index 0000000..081c4f1
--- /dev/null
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -0,0 +1,395 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[ConFold]{Constant Folder}
+
+ToDo:
+   check boundaries before folding, e.g. we can fold the Float addition
+   (i1 + i2) only if it results	in a valid Float.
+
+\begin{code}
+module PrelRules ( primOpRule, builtinRules ) where
+
+#include "HsVersions.h"
+
+import CoreSyn
+import Rules		( ProtoCoreRule(..) )
+import Id		( getIdUnfolding )
+import Const		( mkMachInt, mkMachWord, Literal(..), Con(..) )
+import PrimOp		( PrimOp(..), primOpOcc )
+import TysWiredIn	( trueDataCon, falseDataCon )
+import TyCon		( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import DataCon		( dataConTag, dataConTyCon, fIRST_TAG )
+import CoreUnfold	( maybeUnfoldingTemplate )
+import CoreUtils	( exprIsValue, cheapEqExpr )
+import Type		( splitTyConApp_maybe )
+import OccName		( occNameUserString)
+import ThinAir		( unpackCStringFoldrId )
+import Maybes		( maybeToBool )
+import Char		( ord, chr )
+import Outputable
+
+#if __GLASGOW_HASKELL__ >= 404
+import GlaExts		( fromInt )
+#endif
+\end{code}
+
+
+
+\begin{code}
+primOpRule :: PrimOp -> CoreRule
+primOpRule op 
+  = BuiltinRule (primop_rule op)
+  where
+    op_name = _PK_ (occNameUserString (primOpOcc op))
+    op_name_case = op_name _APPEND_ SLIT("case")
+
+    -- ToDo:	something for integer-shift ops?
+    --		NotOp
+    --		Int2WordOp	-- SIGH: these two cause trouble in unfoldery
+    --		Int2AddrOp	-- as we can't distinguish unsigned literals in interfaces (ToDo?)
+
+    primop_rule SeqOp	    = seqRule
+    primop_rule TagToEnumOp = tagToEnumRule
+    primop_rule DataToTagOp = dataToTagRule
+
+	-- Addr operations
+    primop_rule Addr2IntOp	= oneLit (addr2IntOp op_name)
+ 
+	-- Char operations
+    primop_rule OrdOp   	= oneLit (chrOp op_name)
+ 
+	-- Int/Word operations
+    primop_rule IntAddOp    = twoLits (intOp2 (+) op_name)
+    primop_rule IntSubOp    = twoLits (intOp2 (-) op_name)
+    primop_rule IntMulOp    = twoLits (intOp2 (*) op_name)
+    primop_rule IntQuotOp   = twoLits (intOp2Z quot op_name)
+    primop_rule IntRemOp    = twoLits (intOp2Z rem  op_name)
+    primop_rule IntNegOp    = oneLit  (negOp op_name)
+
+    primop_rule ChrOp    	= oneLit (intCoerce (mkCharVal . chr) op_name)
+    primop_rule Int2FloatOp	= oneLit (intCoerce mkFloatVal	      op_name)
+    primop_rule Int2DoubleOp	= oneLit (intCoerce mkDoubleVal       op_name)
+    primop_rule Word2IntOp 	= oneLit (intCoerce mkIntVal	      op_name)
+    primop_rule Int2WordOp 	= oneLit (intCoerce mkWordVal	      op_name)
+
+	-- Float
+    primop_rule FloatAddOp   = twoLits (floatOp2 (+) op_name)
+    primop_rule FloatSubOp   = twoLits (floatOp2 (-) op_name)
+    primop_rule FloatMulOp   = twoLits (floatOp2 (*) op_name)
+    primop_rule FloatDivOp   = twoLits (floatOp2Z (/) op_name)
+    primop_rule FloatNegOp   = oneLit  (negOp op_name)
+
+	-- Double
+    primop_rule DoubleAddOp   = twoLits (doubleOp2 (+) op_name)
+    primop_rule DoubleSubOp   = twoLits (doubleOp2 (-) op_name)
+    primop_rule DoubleMulOp   = twoLits (doubleOp2 (*) op_name)
+    primop_rule DoubleDivOp   = twoLits (doubleOp2Z (/) op_name)
+
+	-- Relational operators
+    primop_rule IntEqOp  = relop (==) op_name `or_rule` litVar True  op_name_case
+    primop_rule IntNeOp  = relop (/=) op_name `or_rule` litVar False op_name_case
+    primop_rule CharEqOp = relop (==) op_name `or_rule` litVar True  op_name_case
+    primop_rule CharNeOp = relop (/=) op_name `or_rule` litVar False op_name_case
+
+    primop_rule IntGtOp		= relop (>)  op_name
+    primop_rule IntGeOp		= relop (>=) op_name
+    primop_rule IntLeOp		= relop (<=) op_name
+    primop_rule IntLtOp		= relop (<)  op_name
+
+    primop_rule CharGtOp	= relop (>)  op_name
+    primop_rule CharGeOp	= relop (>=) op_name
+    primop_rule CharLeOp	= relop (<=) op_name
+    primop_rule CharLtOp	= relop (<)  op_name
+
+    primop_rule FloatGtOp	= relop (>)  op_name
+    primop_rule FloatGeOp	= relop (>=) op_name
+    primop_rule FloatLeOp	= relop (<=) op_name
+    primop_rule FloatLtOp	= relop (<)  op_name
+    primop_rule FloatEqOp	= relop (==) op_name
+    primop_rule FloatNeOp	= relop (/=) op_name
+
+    primop_rule DoubleGtOp	= relop (>)  op_name
+    primop_rule DoubleGeOp	= relop (>=) op_name
+    primop_rule DoubleLeOp	= relop (<=) op_name
+    primop_rule DoubleLtOp	= relop (<)  op_name
+    primop_rule DoubleEqOp	= relop (==) op_name
+    primop_rule DoubleNeOp	= relop (/=) op_name
+
+    primop_rule WordGtOp	= relop (>)  op_name
+    primop_rule WordGeOp	= relop (>=) op_name
+    primop_rule WordLeOp	= relop (<=) op_name
+    primop_rule WordLtOp	= relop (<)  op_name
+    primop_rule WordEqOp	= relop (==) op_name
+    primop_rule WordNeOp	= relop (/=) op_name
+
+    primop_rule other		= \args -> Nothing
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Doing the business}
+%*									*
+%************************************************************************
+
+\begin{code}
+--------------------------
+intCoerce :: Num a => (a -> CoreExpr) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr)
+intCoerce fn name (MachInt i _) = Just (name, fn (fromInteger i))
+
+--------------------------
+relop cmp name = twoLits (\l1 l2 -> Just (name, if l1 `cmp` l2 then trueVal else falseVal))
+
+--------------------------
+negOp name (MachFloat f)  = Just (name, mkFloatVal (-f))
+negOp name (MachDouble d) = Just (name, mkDoubleVal (-d))
+negOp name (MachInt i _)  = Just (name, mkIntVal (-i))
+
+chrOp name (MachChar c) = Just (name, mkIntVal (fromInt (ord c)))
+
+addr2IntOp name (MachAddr i) = Just (name, mkIntVal i)
+
+--------------------------
+intOp2 op name l1@(MachInt i1 s1) l2@(MachInt i2 s2)
+  | (result > fromInt maxInt) || (result < fromInt minInt) 
+	-- Better tell the user that we've overflowed...
+	-- ..not that it stops us from actually folding!
+  = pprTrace "Warning:" (text "Integer overflow in expression: " <> 
+	                 ppr name <+> ppr l1 <+> ppr l2) $
+    Just (name, mkIntVal result)
+
+  | otherwise
+  = ASSERT( s1 && s2 )		-- Both should be signed
+    Just (name, mkIntVal result)
+  where
+    result = i1 `op` i2
+
+intOp2Z op name (MachInt i1 s1) (MachInt i2 s2)
+  | i2 == 0   = Nothing	-- Don't do it if the dividend < 0
+  | otherwise = Just (name, mkIntVal (i1 `op` i2))
+
+
+--------------------------
+floatOp2  op name (MachFloat f1) (MachFloat f2)
+  = Just (name, mkFloatVal (f1 `op` f2))
+
+floatOp2Z op name (MachFloat f1) (MachFloat f2)
+  | f1 /= 0   = Just (name, mkFloatVal (f1 `op` f2))
+  | otherwise = Nothing
+
+
+--------------------------
+doubleOp2  op name (MachDouble f1) (MachDouble f2)
+  = Just (name, mkDoubleVal (f1 `op` f2))
+
+doubleOp2Z op name (MachDouble f1) (MachDouble f2)
+  | f1 /= 0   = Just (name, mkDoubleVal (f1 `op` f2))
+  | otherwise = Nothing
+
+
+--------------------------
+	-- This stuff turns
+	--	n ==# 3#
+	-- into
+	--	case n of
+	--	  3# -> True
+	--	  m  -> False
+	--
+	-- This is a Good Thing, because it allows case-of case things
+	-- to happen, and case-default absorption to happen.  For
+	-- example:
+	--
+	--	if (n ==# 3#) || (n ==# 4#) then e1 else e2
+	-- will transform to
+	--	case n of
+	--	  3# -> e1
+	--	  4# -> e1
+	--	  m  -> e2
+	-- (modulo the usual precautions to avoid duplicating e1)
+
+litVar :: Bool		-- True <=> equality, False <=> inequality
+        -> RuleName
+	-> RuleFun
+litVar is_eq name [Con (Literal lit) _, Var var] = do_lit_var is_eq name lit var
+litVar is_eq name [Var var, Con (Literal lit) _] = do_lit_var is_eq name lit var
+litVar is_eq name other			 	 = Nothing
+
+do_lit_var is_eq name lit var 
+  = Just (name, Case (Var var) var [(Literal lit, [], val_if_eq),
+			            (DEFAULT,     [], val_if_neq)])
+  where
+    val_if_eq  | is_eq     = trueVal
+	       | otherwise = falseVal
+    val_if_neq | is_eq     = falseVal
+	       | otherwise = trueVal
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Vaguely generic functions
+%*									*
+%************************************************************************
+
+\begin{code}
+type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)
+
+or_rule :: RuleFun -> RuleFun -> RuleFun
+or_rule r1 r2 args = case r1 args of
+		   Just stuff -> Just stuff
+		   Nothing    -> r2 args
+
+twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
+twoLits rule [Con (Literal l1) _, Con (Literal l2) _] = rule l1 l2
+twoLits rule other				      = Nothing
+
+oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
+oneLit rule [Con (Literal l1) _] = rule l1
+oneLit rule other		 = Nothing
+
+
+trueVal       = Con (DataCon trueDataCon)  []
+falseVal      = Con (DataCon falseDataCon) []
+mkIntVal i    = Con (Literal (mkMachInt  i)) []
+mkCharVal c   = Con (Literal (MachChar   c)) []
+mkWordVal w   = Con (Literal (mkMachWord w)) []
+mkFloatVal f  = Con (Literal (MachFloat  f)) []
+mkDoubleVal d = Con (Literal (MachDouble d)) []
+\end{code}
+
+						
+%************************************************************************
+%*									*
+\subsection{Special rules for seq, tagToEnum, dataToTag}
+%*									*
+%************************************************************************
+
+In the parallel world, we use _seq_ to control the order in which
+certain expressions will be evaluated.  Operationally, the expression
+``_seq_ a b'' evaluates a and then evaluates b.  We have an inlining
+for _seq_ which translates _seq_ to:
+
+   _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
+
+Now, we know that the seq# primitive will never return 0#, but we
+don't let the simplifier know that.  We also use a special error
+value, parError#, which is *not* a bottoming Id, so as far as the
+simplifier is concerned, we have to evaluate seq# a before we know
+whether or not y will be evaluated.
+
+If we didn't have the extra case, then after inlining the compiler might
+see:
+	f p q = case seq# p of { _ -> p+q }
+
+If it sees that, it can see that f is strict in q, and hence it might
+evaluate q before p!  The "0# ->" case prevents this happening.
+By having the parError# branch we make sure that anything in the
+other branch stays there!
+
+This is fine, but we'd like to get rid of the extraneous code.  Hence,
+we *do* let the simplifier know that seq# is strict in its argument.
+As a result, we hope that `a' will be evaluated before seq# is called.
+At this point, we have a very special and magical simpification which
+says that ``seq# a'' can be immediately simplified to `1#' if we
+know that `a' is already evaluated.
+
+NB: If we ever do case-floating, we have an extra worry:
+
+    case a of
+      a' -> let b' = case seq# a of { True -> b; False -> parError# }
+	    in case b' of ...
+
+    =>
+
+    case a of
+      a' -> let b' = case True of { True -> b; False -> parError# }
+	    in case b' of ...
+
+    =>
+
+    case a of
+      a' -> let b' = b
+	    in case b' of ...
+
+    =>
+
+    case a of
+      a' -> case b of ...
+
+The second case must never be floated outside of the first!
+
+\begin{code}
+seqRule [Type ty, arg] | exprIsValue arg = Just (SLIT("Seq"), mkIntVal 1)
+seqRule other				 = Nothing
+\end{code}
+
+
+\begin{code}
+tagToEnumRule [Type ty, Con (Literal (MachInt i _)) _]
+  = ASSERT( isEnumerationTyCon tycon ) 
+    Just (SLIT("TagToEnum"), Con (DataCon dc) [])
+  where 
+    tag = fromInteger i
+    constrs = tyConDataCons tycon
+    (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
+    (Just (tycon,_)) = splitTyConApp_maybe ty
+
+tagToEnumRule other = Nothing
+\end{code}
+
+For dataToTag#, we can reduce if either 
+	
+	(a) the argument is a constructor
+	(b) the argument is a variable whose unfolding is a known constructor
+
+\begin{code}
+dataToTagRule [_, val_arg]
+  = case val_arg of
+	Con (DataCon dc) _ -> yes dc
+	Var x		   -> case maybeUnfoldingTemplate (getIdUnfolding x) of
+				Just (Con (DataCon dc) _) -> yes dc
+				other			  -> Nothing
+	other		   -> Nothing
+  where
+    yes dc = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+	     Just (SLIT("DataToTag"), 
+		   mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
+
+dataToTagRule other = Nothing
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Built in rules}
+%*									*
+%************************************************************************
+
+\begin{code}
+builtinRules :: [ProtoCoreRule]
+builtinRules
+  = [ ProtoCoreRule False unpackCStringFoldrId 
+		    (BuiltinRule match_append_lit_str)
+    ]
+
+
+-- unpack "foo" c (unpack "baz" c n)  =  unpack "foobaz" c n
+
+match_append_lit_str [Type ty1,
+		      Con (Literal (MachStr s1)) [],
+		      c1,
+		      Var unpk `App` Type ty2 
+			       `App` Con (Literal (MachStr s2)) []
+			       `App` c2
+			       `App` n
+		     ]
+  | unpk == unpackCStringFoldrId && 
+    c1 `cheapEqExpr` c2
+  = ASSERT( ty1 == ty2 )
+    Just (SLIT("AppendLitString"),
+	  Var unpk `App` Type ty1
+		   `App` Con (Literal (MachStr (s1 _APPEND_ s2))) []
+		   `App` c1
+		   `App` n)
+
+match_append_lit_str other = Nothing
+\end{code}		
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 4aa237f..13fc502 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -6,8 +6,8 @@
 \begin{code}
 module PrimOp (
 	PrimOp(..), allThePrimOps,
-	primOpType, primOpSig, primOpUsg,
-	mkPrimOpIdName, primOpRdrName, primOpTag,
+	primOpType, primOpSig, primOpUsg, primOpArity,
+	mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc,
 
 	commutableOp,
 
@@ -40,6 +40,7 @@ import Type		( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
                           UsageAnn(..), mkUsgTy
 			)
 import Unique		( Unique, mkPrimOpIdUnique )
+import BasicTypes	( Arity )
 import PrelMods		( pREL_GHC, pREL_GHC_Name )
 import Outputable
 import Util		( assoc, zipWithEqual )
@@ -2200,6 +2201,14 @@ primOpNeedsWrapper other_op 	    	= False
 \end{code}
 
 \begin{code}
+primOpArity :: PrimOp -> Arity
+primOpArity op 
+  = case (primOpInfo op) of
+      Monadic occ ty			  -> 1
+      Dyadic occ ty			  -> 2
+      Compare occ ty 			  -> 2
+      GenPrimOp occ tyvars arg_tys res_ty -> length arg_tys
+		
 primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead
 primOpType op
   = case (primOpInfo op) of
diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs
index 147dde2..c935113 100644
--- a/ghc/compiler/prelude/ThinAir.lhs
+++ b/ghc/compiler/prelude/ThinAir.lhs
@@ -59,12 +59,13 @@ thinAirIdNames
 
 	-- String literals
     , (varQual pREL_PACK_Name SLIT("packCString#"),   packCStringIdKey)
-    , (varQual pREL_PACK_Name SLIT("unpackCString#"), unpackCStringIdKey)
-    , (varQual pREL_PACK_Name SLIT("unpackNBytes#"),  unpackCString2IdKey)
-    , (varQual pREL_PACK_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
-    , (varQual pREL_PACK_Name SLIT("unpackFoldrCString#"),  unpackCStringFoldrIdKey)
 
 	-- Folds and builds; introduced by desugaring list comprehensions
+    , (varQual pREL_BASE_Name SLIT("unpackNBytes#"),  unpackCString2IdKey)
+    , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey)
+    , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
+    , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"),  unpackCStringFoldrIdKey)
+
     , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey)
     , (varQual pREL_BASE_Name SLIT("build"), buildIdKey)
     ]
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 970838f..13db4fa 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -43,8 +43,8 @@ import Name		( mkLocalName, tidyOccName, tidyTopName,
 			  NamedThing(..), OccName
 			)
 import TyCon		( TyCon, isDataTyCon )
-import PrimOp		( PrimOp(..) )
 import PrelInfo		( unpackCStringId, unpackCString2Id, addr2IntegerId )
+import PrelRules	( builtinRules )
 import Type		( Type, splitAlgTyConApp_maybe, 
 			  isUnLiftedType,
 			  tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
@@ -94,7 +94,10 @@ core2core core_todos binds rules
 
         better_rules <- simplRules ru_us rules binds
 
-	let (binds1, rule_base) = prepareRuleBase binds better_rules
+	let all_rules = builtinRules ++ better_rules
+	-- Here is where we add in the built-in rules
+
+	let (binds1, rule_base) = prepareRuleBase binds all_rules
 
 	-- Do the main business
 	(stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 
@@ -184,9 +187,20 @@ simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
   = returnSmpl rule	-- No need to fiddle with imported rules
   | otherwise
   = simplBinders bndrs			$ \ bndrs' -> 
-    mapSmpl simplExpr args		`thenSmpl` \ args' ->
+    mapSmpl simpl_arg args		`thenSmpl` \ args' ->
     simplExpr rhs			`thenSmpl` \ rhs' ->
     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+
+simpl_arg e 
+--  I've seen rules in which a LHS like 
+--	augment g (build h) 
+-- turns into
+--	augment (\a. g a) (build h)
+-- So it's a help to eta-reduce the args as we simplify them.
+-- Otherwise we don't match when given an argument like
+--	(\a. h a a)
+  = simplExpr e 	`thenSmpl` \ e' ->
+    returnSmpl (etaCoreExpr e')
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 2d9740b..92fb9dd 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -214,10 +214,12 @@ simplExprF expr@(Con (PrimOp op) args) cont
 	--	case (eqChar# x 'a') of ...
 	-- ==>  
 	-- 	case (case x of 'a' -> True; other -> False) of ...
-     case tryPrimOp op args2 of
+
+    case tryPrimOp op args2 of
 	  Just e' -> zapSubstEnv (simplExprF e' cont2)
 	  Nothing -> rebuild (Con (PrimOp op) args2) cont2
 
+
 simplExprF (Con con@(DataCon _) args) cont
   = simplConArgs args		$ \ args' ->
     rebuild (Con con args') cont
@@ -790,9 +792,9 @@ completeCall black_list_fn in_scope occ var cont
     else
 	-- Try rules first
     case lookupRule in_scope var args' of
-	Just (rule_name, rule_rhs, rule_args) -> 
+	Just (rule_name, rule_rhs) -> 
 		tick (RuleFired rule_name)			`thenSmpl_`
-		zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args cont'))
+		zapSubstEnv (simplExprF rule_rhs cont')
 			-- See note above about zapping the substitution here
 	
 	Nothing -> rebuild (mkApps (Var var) args') cont'
@@ -1050,66 +1052,9 @@ rebuild expr (CoerceIt to_ty cont)
 rebuild expr (InlinePlease cont)
   = rebuild (Note InlineCall expr) cont
 
--- 	Case of known constructor or literal
-rebuild expr@(Con con args) (Select _ bndr alts se cont)
-  | conOkForAlt con	-- Knocks out PrimOps and NoRepLits
-  = knownCon expr con args bndr alts se cont
-
-
----------------------------------------------------------
--- 	The other Select cases
-
 rebuild scrut (Select _ bndr alts se cont)
-  | 	-- Check that the RHSs are all the same, and
-	-- don't use the binders in the alternatives
-	-- This test succeeds rapidly in the common case of
-	-- a single DEFAULT alternative
-    all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-
-	-- Check that the scrutinee can be let-bound instead of case-bound
-    && (   exprOkForSpeculation scrut
-		-- OK not to evaluate it
-		-- This includes things like (==# a# b#)::Bool
-		-- so that we simplify 
-		-- 	case ==# a# b# of { True -> x; False -> x }
-		-- to just
-		--	x
-		-- This particular example shows up in default methods for
-		-- comparision operations (e.g. in (>=) for Int.Int32)
-	|| exprIsValue scrut			-- It's already evaluated
-	|| var_demanded_later scrut		-- It'll be demanded later
-
---      || not opt_SimplPedanticBottoms)	-- Or we don't care!
---	We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- 	but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- 	its argument:  case x of { y -> dataToTag# y }
---	Here we must *not* discard the case, because dataToTag# just fetches the tag from
---	the info pointer.  So we'll be pedantic all the time, and see if that gives any
--- 	other problems
-       )
-
---    && opt_SimplDoCaseElim
---	[June 99; don't test this flag.  The code generator dies if it sees
---		case (\x.e) of f -> ...  
---	so better to always do it
-
-   	-- Get rid of the case altogether
-	-- See the extensive notes on case-elimination below
-	-- Remember to bind the binder though!
-  = tick (CaseElim bndr)			`thenSmpl_` (
-    setSubstEnv se				$			
-    simplBinder bndr				$ \ bndr' ->
-    completeBinding bndr bndr' False False scrut 	$
-    simplExprF rhs1 cont)
-
-  | otherwise
   = rebuild_case scrut bndr alts se cont
-  where
-    (rhs1:other_rhss)		 = [rhs | (_,_,rhs) <- alts]
-    binders_unused (_, bndrs, _) = all isDeadBinder bndrs
 
-    var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr)	-- It's going to be evaluated later
-    var_demanded_later other   = False
 \end{code}
 
 Case elimination [see the code above]
@@ -1194,6 +1139,67 @@ If so, then we can replace the case with one of the rhss.
 Blob of helper functions for the "case-of-something-else" situation.
 
 \begin{code}
+
+---------------------------------------------------------
+-- 	Case of known constructor or literal
+
+rebuild_case scrut@(Con con args) bndr alts se cont
+  | conOkForAlt con	-- Knocks out PrimOps and NoRepLits
+  = knownCon scrut con args bndr alts se cont
+
+---------------------------------------------------------
+-- 	Eliminate the case if possible
+
+rebuild_case scrut bndr alts se cont
+  | 	-- Check that the RHSs are all the same, and
+	-- don't use the binders in the alternatives
+	-- This test succeeds rapidly in the common case of
+	-- a single DEFAULT alternative
+    all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
+
+	-- Check that the scrutinee can be let-bound instead of case-bound
+    && (   exprOkForSpeculation scrut
+		-- OK not to evaluate it
+		-- This includes things like (==# a# b#)::Bool
+		-- so that we simplify 
+		-- 	case ==# a# b# of { True -> x; False -> x }
+		-- to just
+		--	x
+		-- This particular example shows up in default methods for
+		-- comparision operations (e.g. in (>=) for Int.Int32)
+	|| exprIsValue scrut			-- It's already evaluated
+	|| var_demanded_later scrut		-- It'll be demanded later
+
+--      || not opt_SimplPedanticBottoms)	-- Or we don't care!
+--	We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- 	but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- 	its argument:  case x of { y -> dataToTag# y }
+--	Here we must *not* discard the case, because dataToTag# just fetches the tag from
+--	the info pointer.  So we'll be pedantic all the time, and see if that gives any
+-- 	other problems
+       )
+
+--    && opt_SimplDoCaseElim
+--	[June 99; don't test this flag.  The code generator dies if it sees
+--		case (\x.e) of f -> ...  
+--	so better to always do it
+
+   	-- Get rid of the case altogether
+	-- See the extensive notes on case-elimination above
+	-- Remember to bind the binder though!
+  = tick (CaseElim bndr)			`thenSmpl_` (
+    setSubstEnv se				$			
+    simplBinder bndr				$ \ bndr' ->
+    completeBinding bndr bndr' False False scrut 	$
+    simplExprF rhs1 cont)
+
+  where
+    (rhs1:other_rhss)		 = [rhs | (_,_,rhs) <- alts]
+    binders_unused (_, bndrs, _) = all isDeadBinder bndrs
+
+    var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr)	-- It's going to be evaluated later
+    var_demanded_later other   = False
+
 ---------------------------------------------------------
 -- 	Case of something else
 
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 864013b..f1578c2 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module Rules (
-	RuleBase, prepareRuleBase, lookupRule, 
+	RuleBase, prepareRuleBase, lookupRule, addRule,
 	addIdSpecialisations,
 	ProtoCoreRule(..), pprProtoCoreRule,
 	orphanRule
@@ -14,11 +14,12 @@ module Rules (
 #include "HsVersions.h"
 
 import CoreSyn		-- All of it
+import Const		( Con(..), Literal(..) )
 import OccurAnal	( occurAnalyseExpr, tagBinders, UsageDetails )
 import BinderInfo	( markMany )
 import CoreFVs		( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
 import CoreUnfold	( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils	( eqExpr )
+import CoreUtils	( eqExpr, cheapEqExpr )
 import PprCore		( pprCoreRule )
 import Subst		( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
 			  mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
@@ -88,7 +89,7 @@ where pi' :: Lift Int# is the specialised version of pi.
 %************************************************************************
 
 \begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 -- See comments on matchRule
 matchRules in_scope [] args = Nothing
 matchRules in_scope (rule:rules) args
@@ -97,11 +98,11 @@ matchRules in_scope (rule:rules) args
 	Nothing	    -> matchRules in_scope rules args
 
 
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 
--- If (matchRule rule args) returns Just (name,rhs,args')
+-- If (matchRule rule args) returns Just (name,rhs)
 -- then (f args) matches the rule, and the corresponding
--- rewritten RHS is (rhs args').
+-- rewritten RHS is rhs
 --
 -- The bndrs and rhs is occurrence-analysed
 --
@@ -116,7 +117,7 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
 --		 map (f.g) x)		-- rhs
 --	  
 -- Then the call: matchRule the_rule [e1,map e2 e3]
---	  = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
+--	  = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
 --
 -- Any 'surplus' arguments in the input are simply put on the end
 -- of the output.
@@ -142,6 +143,8 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
 --	(\x->E)	matches (\x->F x)
 
 
+matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args
+
 matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
   = go tpl_args args emptySubst
 	-- We used to use the in_scope set, but I don't think that's necessary
@@ -154,14 +157,25 @@ matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
    go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
 
 	-- Two easy ways to terminate
-   go []		 []	    subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
-   go []		 args	    subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
+   go [] []	    subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
+   go [] args	    subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
 
 	-- One tiresome way to terminate: check for excess unmatched
 	-- template arguments
-   go tpl_args		 []	    subst = Nothing	-- Failure
+   go tpl_args []   subst = Nothing	-- Failure
 
 
+   -----------------------
+   app_match subst fn vs = foldl go fn vs
+	where	
+	  senv    = substEnv subst
+	  go fn v = case lookupSubstEnv senv v of
+			Just (DoneEx ex)  -> fn `App` ex 
+			Just (DoneTy ty)  -> fn `App` Type ty
+			-- Substitution should bind them all!
+
+
+   -----------------------
 {-	The code below tries to match even if there are more 
 	template args than real args.
 
@@ -200,15 +214,6 @@ matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
    eta_complete other vars = Nothing
 -}
 
-   -----------------------
-   mk_result_args subst vs = map go vs
-	where	
-	  senv = substEnv subst
-	  go v = case lookupSubstEnv senv v of
-			Just (DoneEx ex)  -> ex
-			Just (DoneTy ty)  -> Type ty
-			-- Substitution should bind them all!
-
 
 zapOccInfo bndr | isTyVar bndr = bndr
 		| otherwise    = zapLamIdInfo bndr
@@ -399,6 +404,10 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules
 -- We make no check for rules that unify without one dominating
 -- the other.   Arguably this would be a bug.
 
+addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _)
+  = Rules (rule:rules) rhs_fvs
+	-- Put it at the start for lack of anything better
+
 addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
   = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
   where
@@ -451,7 +460,7 @@ data ProtoCoreRule
 
 pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
 
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
 lookupRule in_scope fn args
   = case getIdSpecialisation fn of
 	Rules rules _ -> matchRules in_scope rules args
@@ -480,10 +489,10 @@ type RuleBase = (IdSet,		-- Imported Ids that have rules attached
 -- so that the opportunity to apply the rule isn't lost too soon
 
 prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds rules
+prepareRuleBase binds all_rules
   = (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
   where
-    (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
+    (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_rules
     imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
 
 	-- rule_fvs is the set of all variables mentioned in rules
@@ -526,4 +535,3 @@ add_rule (ProtoCoreRule _ id rule)
 
 addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
 \end{code}
-
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 2cf4095..6eae048 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -35,7 +35,7 @@ import WorkWrap		( mkWrapper )
 import PrimOp		( PrimOp(..) )
 
 import Id		( Id, mkId, mkVanillaId,
-			  isPrimitiveId_maybe, isDataConId_maybe
+			  isDataConId_maybe
 			)
 import IdInfo
 import DataCon		( dataConSig, dataConArgTys )
@@ -201,18 +201,18 @@ tcCoreExpr (UfVar name)
     returnTc (Var id)
 
 tcCoreExpr (UfCon con args) 
-  = tcUfCon con			`thenTc` \ con' ->
-    mapTc tcCoreExpr args	`thenTc` \ args' ->
-    returnTc (Con con' args')
+  = mapTc tcCoreExpr args	`thenTc` \ args' ->
+    tcUfCon con args'
 
 tcCoreExpr (UfTuple name args) 
-  = tcUfDataCon name		`thenTc` \ con ->
+  = 	-- See notes with tcUfCon (UfDataCon ...)
+    tcVar name			`thenTc` \ con_id ->
     mapTc tcCoreExpr args	`thenTc` \ args' ->
     let
 	-- Put the missing type arguments back in
 	con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
     in
-    returnTc (Con con con_args)
+    returnTc (mkApps (Var con_id) con_args)
 
 tcCoreExpr (UfLam bndr body)
   = tcCoreLamBndr bndr 		$ \ bndr' ->
@@ -262,50 +262,54 @@ tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 tcCoreNote UfInlineCall = returnTc InlineCall 
 
 
--- rationalTy isn't built in so, we have to construct it
--- (the "ty" part of the incoming literal is simply bottom)
-tcUfCon (UfLitCon (NoRepRational lit _)) 
-  = tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
-    let
-	rational_ty  = mkSynTy rational_tycon []
-    in
-    returnTc (Literal (NoRepRational lit rational_ty)) 
-
--- Similarly for integers and strings, except that they are wired in
-tcUfCon (UfLitCon (NoRepInteger lit _)) 
-  = returnTc (Literal (NoRepInteger lit integerTy))
-tcUfCon (UfLitCon (NoRepStr lit _))
-  = returnTc (Literal (NoRepStr lit stringTy))
-
-tcUfCon (UfLitCon other_lit)
-  = returnTc (Literal other_lit)
+----------------------------------
+tcUfCon (UfLitCon lit) args
+  = ASSERT( null args)
+    tcUfLit lit		`thenTc` \ lit ->
+    returnTc (Con (Literal lit) [])
 
 -- The dreaded lit-lits are also similar, except here the type
 -- is read in explicitly rather than being implicit
-tcUfCon (UfLitLitCon lit ty)
-  = tcHsType ty		`thenTc` \ ty' ->
-    returnTc (Literal (MachLitLit lit ty'))
-
-tcUfCon (UfDataCon name) = tcUfDataCon name
-
-tcUfCon (UfPrimOp name)
-  = tcVar name		`thenTc` \ op_id ->
-    case isPrimitiveId_maybe op_id of
-	Just op -> returnTc (PrimOp op)
-	Nothing -> failWithTc (badPrimOp name)
-
-tcUfCon (UfCCallOp str is_dyn casm gc)
-  = case is_dyn of
-       True  -> 
-          tcGetUnique `thenNF_Tc` \ u ->
-	  returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
-       False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
-
-tcUfDataCon name
+tcUfCon (UfLitLitCon lit ty) args
+  = ASSERT( null args )
+    tcHsType ty		`thenTc` \ ty' ->
+    returnTc (Con (Literal (MachLitLit lit ty')) [])
+
+-- Primops are reverse-engineered
+-- into applications of their Ids.  In this way, any
+-- RULES that apply to the Id will work when this thing is unfolded.
+-- It's a bit of a hack, but it works nicely
+-- Can't do it for datacons, because the data con Id doesn't necessarily
+-- have the same type as the data con (existentials)
+
+tcUfCon (UfPrimOp name)  args = tcVar name		`thenTc` \ op_id ->
+				returnTc (mkApps (Var op_id) args)
+
+tcUfCon (UfDataCon name) args
   = tcVar name		`thenTc` \ con_id ->
     case isDataConId_maybe con_id of
-	Just con -> returnTc (DataCon con)
+	Just con -> returnTc (mkConApp con args)
 	Nothing  -> failWithTc (badCon name)
+
+tcUfCon (UfCCallOp str is_dyn casm gc) args
+  | is_dyn    = tcGetUnique `thenNF_Tc` \ u ->
+	        returnTc (Con (PrimOp (CCallOp (Right u) casm gc cCallConv)) args)
+  | otherwise = returnTc (Con (PrimOp (CCallOp (Left str) casm gc cCallConv)) args)
+
+----------------------------------
+tcUfLit (NoRepRational lit _)
+  =	-- rationalTy isn't built in so, we have to construct it
+	-- (the "ty" part of the incoming literal is simply bottom)
+    tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
+    let
+	rational_ty  = mkSynTy rational_tycon []
+    in
+    returnTc (NoRepRational lit rational_ty)
+
+-- Similarly for integers and strings, except that they are wired in
+tcUfLit (NoRepInteger lit _) = returnTc (NoRepInteger lit integerTy)
+tcUfLit (NoRepStr lit _)     = returnTc (NoRepStr lit stringTy)
+tcUfLit other_lit	     = returnTc other_lit
 \end{code}
 
 \begin{code}
diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index dcf8f31..84b7a9c 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -243,7 +243,16 @@ augment g xs = g (:) xs
 
 "foldr/cons"	forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
 "foldr/nil"	forall k z.	 foldr k z []     = z 
+
+"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
+		       (h::forall b. (a->b->b) -> b -> b) .
+		       augment g (build h) = build (\c n -> g c (h c n))
+"augment/nil"   forall (g::forall b. (a->b->b) -> b -> b) .
+			augment g [] = build g
  #-}
+
+-- This rule is true, but not (I think) useful:
+--	augment g (augment h t) = augment (\cn -> g c (h c n)) t
 \end{code}
 
 
@@ -545,3 +554,71 @@ ltInt	(I# x) (I# y) = x <# y
 leInt	(I# x) (I# y) = x <=# y
 \end{code}
 
+
+%********************************************************
+%*							*
+\subsection{Unpacking C strings}
+%*							*
+%********************************************************
+
+This code is needed for virtually all programs, since it's used for
+unpacking the strings of error messages.
+
+\begin{code}
+unpackCString#  :: Addr# -> [Char]
+{-# INLINE unpackCString# #-}
+unpackCString# a = build (unpackFoldrCString# a)
+
+unpackCStringList#  :: Addr# -> [Char]
+unpackCStringList# addr 
+  = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'# = []
+      | otherwise	   = C# ch : unpack (nh +# 1#)
+      where
+	ch = indexCharOffAddr# addr nh
+
+unpackAppendCString# :: Addr# -> [Char] -> [Char]
+unpackAppendCString# addr rest
+  = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'# = rest
+      | otherwise	   = C# ch : unpack (nh +# 1#)
+      where
+	ch = indexCharOffAddr# addr nh
+
+unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
+unpackFoldrCString# addr f z 
+  = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'# = z
+      | otherwise	   = C# ch `f` unpack (nh +# 1#)
+      where
+	ch = indexCharOffAddr# addr nh
+
+unpackNBytes#      :: Addr# -> Int#   -> [Char]
+  -- This one is called by the compiler to unpack literal 
+  -- strings with NULs in them; rare. It's strict!
+  -- We don't try to do list deforestation for this one
+
+unpackNBytes# _addr 0#   = []
+unpackNBytes#  addr len# = unpack [] (len# -# 1#)
+    where
+     unpack acc i#
+      | i# <# 0#  = acc
+      | otherwise = 
+	 case indexCharOffAddr# addr i# of
+	    ch -> unpack (C# ch : acc) (i# -# 1#)
+
+{-# RULES
+"unpack-list"    forall a   . unpackFoldrCString# a (:) [] = unpackCStringList# a
+"unpack-append"  forall a n . unpackFoldrCString# a (:) n  = unpackAppendCString# a n
+
+-- There's a built-in rule (in PrelRules.lhs) for
+-- 	unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
+
+  #-}
+\end{code}
diff --git a/ghc/lib/std/PrelPack.hi-boot b/ghc/lib/std/PrelPack.hi-boot
index 8abaa51..37908c8 100644
--- a/ghc/lib/std/PrelPack.hi-boot
+++ b/ghc/lib/std/PrelPack.hi-boot
@@ -8,10 +8,6 @@
 ---------------------------------------------------------------------------
  
 __interface PrelPack 1 where
-__export PrelPack packCStringzh unpackCStringzh unpackNByteszh unpackAppendCStringzh unpackFoldrCStringzh ;
+__export PrelPack packCStringzh ;
 
 1 packCStringzh :: [PrelBase.Char] -> PrelGHC.ByteArrayzh ;
-1 unpackCStringzh :: PrelGHC.Addrzh -> [PrelBase.Char] ;
-1 unpackNByteszh :: PrelGHC.Addrzh -> PrelGHC.Intzh -> [PrelBase.Char] ;
-1 unpackAppendCStringzh :: PrelGHC.Addrzh -> [PrelBase.Char] -> [PrelBase.Char] ;
-1 unpackFoldrCStringzh :: __forall [a] => PrelGHC.Addrzh -> (PrelBase.Char -> a -> a) -> a -> a ;
diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs
index 187d2a7..934ffa7 100644
--- a/ghc/lib/std/PrelPack.lhs
+++ b/ghc/lib/std/PrelPack.lhs
@@ -68,11 +68,14 @@ Primitives for converting Addrs pointing to external
 sequence of bytes into a list of @Char@s:
 
 \begin{code}
-unpackCString  :: Addr{- ptr. to NUL terminated string-} -> [Char]
+unpackCString :: Addr -> [Char]
 unpackCString a@(A# addr)
   | a == nullAddr  = []
   | otherwise	   = unpackCString# addr
      
+unpackNBytes :: Addr -> Int -> [Char]
+unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
+
 unpackCStringST  :: Addr{- ptr. to NUL terminated string-} -> ST s [Char]
 unpackCStringST a@(A# addr)
   | a == nullAddr  = return []
@@ -86,37 +89,12 @@ unpackCStringST a@(A# addr)
       where
 	ch = indexCharOffAddr# addr nh
 
-unpackCString# :: Addr#  -> [Char]
-unpackCString# addr 
-  = unpack 0#
-  where
-    unpack nh
-      | ch `eqChar#` '\0'# = []
-      | otherwise	   = C# ch : unpack (nh +# 1#)
-      where
-	ch = indexCharOffAddr# addr nh
-
-unpackNBytes :: Addr -> Int -> [Char]
-unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
-
 unpackNBytesST :: Addr -> Int -> ST s [Char]
 unpackNBytesST (A# addr) (I# l) = unpackNBytesAccST# addr l []
 
 unpackNBytesAccST :: Addr -> Int -> [Char] -> ST s [Char]
 unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest
 
-unpackNBytes#      :: Addr# -> Int#   -> [Char]
-  -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
-  -- It's strict!
-unpackNBytes# _addr 0#   = []
-unpackNBytes#  addr len# = unpack [] (len# -# 1#)
-    where
-     unpack acc i#
-      | i# <# 0#  = acc
-      | otherwise = 
-	 case indexCharOffAddr# addr i# of
-	    ch -> unpack (C# ch : acc) (i# -# 1#)
-
 unpackNBytesST# :: Addr# -> Int# -> ST s [Char]
 unpackNBytesST# addr# l#   = unpackNBytesAccST# addr# l# []
 
@@ -248,32 +226,3 @@ freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 \end{code}
 
 
-%********************************************************
-%*							*
-\subsection{Misc}
-%*							*
-%********************************************************
-
-The compiler may emit these two
-
-\begin{code}
-unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackAppendCString# addr rest
-  = unpack 0#
-  where
-    unpack nh
-      | ch `eqChar#` '\0'# = rest
-      | otherwise	   = C# ch : unpack (nh +# 1#)
-      where
-	ch = indexCharOffAddr# addr nh
-
-unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
-unpackFoldrCString# addr f z 
-  = unpack 0#
-  where
-    unpack nh
-      | ch `eqChar#` '\0'# = z
-      | otherwise	   = C# ch `f` unpack (nh +# 1#)
-      where
-	ch = indexCharOffAddr# addr nh
-\end{code}