[project @ 1996-12-19 09:10:02 by simonpj]

SLPJ new renamer and lots more

ghc/compiler/HsVersions.h

@@ -110,6 +110,7 @@ you will screw up the layout where they are used in case expressions!
 #  define FAST_STRING	_PackedString
 #  define SLIT(x)	(_packCString (A# x#))
 #  define _CMP_STRING_	cmpPString
+	/* cmpPString defined in utils/Util.lhs */
 #  define _NULL_	_nullPS
 #  define _NIL_		_nilPS
 #  define _CONS_	_consPS

ghc/compiler/Makefile

 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1996/12/18 18:42:48 dnt Exp $
+# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $
 
 TOP = ../..
 FlexSuffixRules = YES
@@ -100,12 +100,26 @@ endif
 INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir))
 SRCS = \
   $(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
-  $(UGNHS) rename/ParseIface.hs
+  $(UGNHS) rename/ParseIface.hs \
+  main/LoopHack.hc
+
+# LoopHack.lhc is an SLPJ addition to fix a profiling problem.  See comments
+# inside it.
+
 LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi))
 HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS)))
 OBJS = \
   $(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \
-  parser/hsclink.o parser/hschooks.o libhsp.a
+  parser/hsclink.o parser/hschooks.o libhsp.a \
+  main/LoopHack.o
+
+main/LoopHack.hc : main/LoopHack.lhc
+	$(RM) $@
+	$(GHC_UNLIT) $<  $@ || ( $(RM) $@ && exit 1 )
+	@chmod 444 $@
+
+main/LoopHack.o : main/LoopHack.hc
+	$(HC) -v -c $(HC_OPTS) $<  
 
 # -----------------------------------------------------------------------------
 # options for the Haskell compiler
@@ -141,7 +155,9 @@ endif
 all :: hsc libhsp.a
 
 hsc : $(OBJS)
-	$(HC) $(HC_OPTS) -o $@ $^
+#	$(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^
+	$(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^
+#	$(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^
 
 parser/hschooks.o : parser/hschooks.c
 	@$(RM) $@
@@ -149,7 +165,7 @@ parser/hschooks.o : parser/hschooks.c
 
 rename/ParseIface.hs : rename/ParseIface.y
 	@$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
-	happy -g rename/ParseIface.y
+	happy +RTS -K2m -RTS -g rename/ParseIface.y
 	@chmod 444 rename/ParseIface.hs
 
 # ----------------------------------------------------------------------------

ghc/compiler/absCSyn/AbsCSyn.lhs

@@ -37,7 +37,7 @@ module AbsCSyn {- (
 
 IMP_Ubiq(){-uitous-}
 
-import CgCompInfo   	( mAX_Vanilla_REG, mAX_Float_REG,
+import Constants   	( mAX_Vanilla_REG, mAX_Float_REG,
 			  mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
 			  lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
 			  lIVENESS_R6, lIVENESS_R7, lIVENESS_R8

ghc/compiler/absCSyn/CLabel.lhs

@@ -290,22 +290,16 @@ isAsmTemp _ 	    	   = False
 \end{code}
 
 C ``static'' or not...
+From the point of view of the code generator, a name is
+externally visible if it should be given put in the .o file's 
+symbol table; that is, made static.
+
 \begin{code}
 externallyVisibleCLabel (TyConLabel tc _) = True
 externallyVisibleCLabel (CaseLabel _ _)	  = False
 externallyVisibleCLabel (AsmTempLabel _)  = False
 externallyVisibleCLabel (RtsLabel _)	  = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _)
-  | isDataCon id 	  = True
-  | is_ConstMethodId id   = True  -- These are here to ensure splitting works
-  | isDictFunId id 	  = True  -- when these values have not been exported
-  | is_DefaultMethodId id = True
-  | is_SuperDictSelId id  = True
-  | otherwise    	  = externallyVisibleId id
-  where
-    is_ConstMethodId   id = maybeToBool (isConstMethodId_maybe   id)
-    is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
-    is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  id)
+externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
 \end{code}
 
 OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the

ghc/compiler/absCSyn/CStrings.lhs

@@ -126,7 +126,7 @@ identToC ps
     char_to_c '<'  = ppPStr SLIT("Zl")
     char_to_c '-'  = ppPStr SLIT("Zm")
     char_to_c '!'  = ppPStr SLIT("Zn")
-    char_to_c '.'  = ppPStr SLIT("Zo")
+    char_to_c '.'  = ppPStr SLIT("_")
     char_to_c '+'  = ppPStr SLIT("Zp")
     char_to_c '\'' = ppPStr SLIT("Zq")
     char_to_c '*'  = ppPStr SLIT("Zt")

ghc/compiler/absCSyn/PprAbsC.lhs

@@ -29,7 +29,7 @@ import AbsCSyn
 import AbsCUtils	( getAmodeRep, nonemptyAbsC,
 			  mixedPtrLocn, mixedTypeLocn
 			)
-import CgCompInfo	( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+import Constants	( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
 import CLabel		( externallyVisibleCLabel, mkErrorStdEntryLabel,
 			  isReadOnly, needsCDecl, pprCLabel,
 			  CLabel{-instance Ord-}

ghc/compiler/basicTypes/FieldLabel.lhs

@@ -10,7 +10,7 @@ module FieldLabel where
 
 IMP_Ubiq(){-uitous-}
 
-import Name		( Name{-instance Eq/Outputable-} )
+import Name		( Name{-instance Eq/Outputable-}, nameUnique )
 import Type		( SYN_IE(Type) )
 \end{code}
 
@@ -42,4 +42,7 @@ instance Outputable FieldLabel where
 
 instance NamedThing FieldLabel where
     getName (FieldLabel n _ _) = n
+
+instance Uniquable FieldLabel where
+    uniqueOf (FieldLabel n _ _) = nameUnique n
 \end{code}

ghc/compiler/basicTypes/IdLoop.lhi

@@ -9,7 +9,7 @@ import PreludeStdIO	( Maybe )
 import BinderInfo	( BinderInfo )
 import CoreSyn		( CoreExpr(..), GenCoreExpr, GenCoreArg )
 import CoreUnfold 	( Unfolding(..), UnfoldingGuidance(..), 
-			  SimpleUnfolding(..), FormSummary(..)  )
+			  SimpleUnfolding(..), FormSummary(..), noUnfolding  )
 import CoreUtils	( unTagBinders )
 import Id		( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
 			  unfoldingUnfriendlyId, getIdInfo, nmbrId,
@@ -34,11 +34,16 @@ import Unique		( Unique )
 import Usage		( GenUsage )
 import Util		( Ord3(..) )
 import WwLib		( mAX_WORKER_ARGS )
+import StdIdInfo	( addStandardIdInfo )	-- Used in Id, but StdIdInfo needs lots of stuff from Id
+
+addStandardIdInfo :: Id -> Id
 
 nullSpecEnv   :: SpecEnv
 isNullSpecEnv :: SpecEnv -> Bool
 
-occurAnalyseGlobalExpr  :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- occurAnalyseGlobalExpr  :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
+
 externallyVisibleId	:: Id	    -> Bool
 isDataCon		:: GenId ty -> Bool
 isWorkerId		:: GenId ty -> Bool
@@ -49,9 +54,7 @@ nullIdEnv		:: UniqFM a
 lookupIdEnv		:: UniqFM b -> GenId a -> Maybe b
 mAX_WORKER_ARGS		:: Int
 nmbrId			:: Id -> NmbrEnv -> (NmbrEnv, Id)
-pprParendGenType		:: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
-unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
-
+pprParendGenType	:: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
 mkMagicUnfoldingFun	:: Unique -> MagicUnfoldingFun
 
 type IdEnv a = UniqFM a
@@ -73,13 +76,15 @@ data NmbrEnv
 data MagicUnfoldingFun
 data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
 
-data Unfolding
-  = NoUnfolding
-  | CoreUnfolding SimpleUnfolding
-  | MagicUnfolding Unique MagicUnfoldingFun
+-- data Unfolding
+--  = NoUnfolding
+--  | CoreUnfolding SimpleUnfolding
+--  | MagicUnfolding Unique MagicUnfoldingFun
 
+data Unfolding
+noUnfolding :: Unfolding
 
-data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) 
+-- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) 
 
 
 data UnfoldingGuidance

ghc/compiler/basicTypes/IdUtils.lhs

@@ -6,21 +6,21 @@
 \begin{code}
 #include "HsVersions.h"
 
-module IdUtils ( primOpNameInfo, primOpId ) where
+module IdUtils ( primOpName ) where
 
 IMP_Ubiq()
 IMPORT_DELOOPER(PrelLoop)		-- here for paranoia checking
 IMPORT_DELOOPER(IdLoop) (SpecEnv)
 
 import CoreSyn
-import CoreUnfold	( UnfoldingGuidance(..), Unfolding )
-import Id		( mkImported, mkTemplateLocals )
+import CoreUnfold	( UnfoldingGuidance(..), Unfolding, mkUnfolding )
+import Id		( mkPrimitiveId, mkTemplateLocals )
 import IdInfo		-- quite a few things
-import Name		( mkPrimitiveName, OrigName(..) )
-import PrelMods		( gHC_BUILTINS )
+import StdIdInfo
+import Name		( mkWiredInIdName )
 import PrimOp		( primOpInfo, tagOf_PrimOp, primOp_str,
 			  PrimOpInfo(..), PrimOpResultInfo(..) )
-import RnHsSyn		( RnName(..) )
+import PrelMods		( gHC__ )
 import Type		( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
 import TysWiredIn	( boolTy )
 import Unique		( mkPrimOpIdUnique )
@@ -28,66 +28,45 @@ import Util		( panic )
 \end{code}
 
 \begin{code}
-primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
-primOpId       :: PrimOp -> Id
-
-primOpNameInfo op = (primOp_str  op, WiredInId (primOpId op))
-
-primOpId op
+primOpName       :: PrimOp -> Name
+primOpName op
   = case (primOpInfo op) of
       Dyadic str ty ->
-	mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
 
       Monadic str ty ->
-	mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
+	mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
 
       Compare str ty ->
-	mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
+	mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
 
       Coercing str ty1 ty2 ->
-	mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
+	mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
 
       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
 	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
 	    (length arg_tys) -- arity
 
       AlgResult str tyvars arg_tys tycon res_tys ->
-	mk_prim_Id op str
+	mk_prim_name op str
 	    tyvars
 	    arg_tys
 	    (mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
 	    (length arg_tys) -- arity
   where
-    mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
-      = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
-	   (noIdInfo `addInfo` (mkArityInfo arity)
-	          `addInfo_UF` (mkUnfolding UnfoldAlways
-			         (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+    mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
+      = name
       where
-	key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	key     = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+	name    = mkWiredInIdName key gHC__ occ_name the_id
+	the_id  = mkPrimitiveId name ty prim_op
 \end{code}
 
-
 \begin{code}
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
 monadic_fun_ty ty = ty `mkFunTy` ty
 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 \end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-
-mk_prim_unfold prim_op tyvars arg_tys
-  = let
-	vars = mkTemplateLocals arg_tys
-    in
-    mkLam tyvars vars $
-    Prim prim_op
-	([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
-\end{code}
-

ghc/compiler/basicTypes/PprEnv.lhs

@@ -12,7 +12,7 @@ module PprEnv (
 	initPprEnv,
 
 	pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
-	pTy, pTyVar, pUVar, pUse,
+	pTy, pTyVarB, pTyVarO, pUVar, pUse,
 	
 	NmbrEnv(..),
 	SYN_IE(NmbrM), initNmbr,
@@ -45,7 +45,9 @@ data PprEnv tyvar uvar bndr occ
 	(PrimOp     -> Pretty)
 	(CostCentre -> Pretty)
 
-	(tyvar -> Pretty)	-- to print tyvars
+	(tyvar -> Pretty)	-- to print tyvar binders
+	(tyvar -> Pretty)	-- to print tyvar occurrences
+
 	(uvar -> Pretty)	-- to print usage vars
 
 	(bndr -> Pretty)	-- to print "major" val_bdrs
@@ -64,6 +66,7 @@ initPprEnv
 	-> Maybe (PrimOp  -> Pretty)
 	-> Maybe (CostCentre -> Pretty)
 	-> Maybe (tyvar -> Pretty)
+	-> Maybe (tyvar -> Pretty)
 	-> Maybe (uvar -> Pretty)
 	-> Maybe (bndr -> Pretty)
 	-> Maybe (bndr -> Pretty)
@@ -75,13 +78,14 @@ initPprEnv
 -- you can specify all the printers individually; if
 -- you don't specify one, you get bottom
 
-initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use
+initPprEnv sty l d p c tvb tvo uv maj_bndr min_bndr occ ty use
   = PE sty
        (demaybe l)
        (demaybe d)
        (demaybe p)
        (demaybe c)
-       (demaybe tv)
+       (demaybe tvb)
+       (demaybe tvo)
        (demaybe uv)
        (demaybe maj_bndr)
        (demaybe min_bndr)
@@ -112,21 +116,22 @@ initPprEnv sty pmaj pmin pocc
 \end{code}
 
 \begin{code}
-pStyle	 (PE s  _  _  _  _  _  _  _  _  _  _  _) = s
-pLit	 (PE _ pp  _  _  _  _  _  _  _  _  _  _) = pp
-pCon	 (PE _	_ pp  _  _  _  _  _  _  _  _  _) = pp
-pPrim	 (PE _	_  _ pp  _  _  _  _  _  _  _  _) = pp
-pSCC	 (PE _	_  _  _ pp  _  _  _  _  _  _  _) = pp
-	     				       
-pTyVar	 (PE _	_  _  _  _ pp  _  _  _  _  _  _) = pp
-pUVar	 (PE _	_  _  _  _  _ pp  _  _  _  _  _) = pp
-      	     				       
-pMajBndr (PE _	_  _  _  _  _  _ pp  _  _  _  _) = pp
-pMinBndr (PE _	_  _  _  _  _  _  _ pp  _  _  _) = pp
-pOcc     (PE _	_  _  _  _  _  _  _  _ pp  _  _) = pp
-	     		       
-pTy      (PE _	_  _  _  _  _  _  _  _  _ pp  _) = pp
-pUse	 (PE _	_  _  _  _  _  _  _  _  _  _ pp) = pp
+pStyle	 (PE s  _  _  _  _  _  _  _  _  _  _  _  _) = s
+pLit	 (PE _ pp  _  _  _  _  _  _  _  _  _  _  _) = pp
+pCon	 (PE _	_ pp  _  _  _  _  _  _  _  _  _  _) = pp
+pPrim	 (PE _	_  _ pp  _  _  _  _  _  _  _  _  _) = pp
+pSCC	 (PE _	_  _  _ pp  _  _  _  _  _  _  _  _) = pp
+	     					 
+pTyVarB	 (PE _	_  _  _  _  pp _  _  _  _  _  _  _) = pp
+pTyVarO	 (PE _	_  _  _  _  _  pp _  _  _  _  _  _) = pp
+pUVar	 (PE _	_  _  _  _  _  _  pp _  _  _  _  _) = pp
+      	     					 
+pMajBndr (PE _	_  _  _  _  _  _  _ pp  _  _  _  _) = pp
+pMinBndr (PE _	_  _  _  _  _  _  _  _ pp  _  _  _) = pp
+pOcc     (PE _	_  _  _  _  _  _  _  _  _ pp  _  _) = pp
+	     		       	 
+pTy      (PE _	_  _  _  _  _  _  _  _  _  _ pp  _) = pp
+pUse	 (PE _	_  _  _  _  _  _  _  _  _  _  _ pp) = pp
 \end{code}
 
 We tend to {\em renumber} everything before printing, so that

ghc/compiler/basicTypes/SrcLoc.lhs

@@ -11,15 +11,17 @@
 #include "HsVersions.h"
 
 module SrcLoc (
-	SrcLoc,			-- abstract
+	SrcLoc,			-- Abstract
+
+	mkSrcLoc,
+	noSrcLoc, isNoSrcLoc,	-- "I'm sorry, I haven't a clue"
 
-	mkSrcLoc, mkSrcLoc2,	-- the usual
-	mkUnknownSrcLoc,	-- "I'm sorry, I haven't a clue"
 	mkIfaceSrcLoc,		-- Unknown place in an interface
 				-- (this one can die eventually ToDo)
-	mkBuiltinSrcLoc,	-- something wired into the compiler
-	mkGeneratedSrcLoc,	-- code generated within the compiler
-	unpackSrcLoc
+
+	mkBuiltinSrcLoc,	-- Something wired into the compiler
+
+	mkGeneratedSrcLoc	-- Code generated within the compiler
     ) where
 
 IMP_Ubiq()
@@ -38,10 +40,12 @@ We keep information about the {\em definition} point for each entity;
 this is the obvious stuff:
 \begin{code}
 data SrcLoc
-  = SrcLoc	FAST_STRING	-- source file name
-		FAST_STRING	-- line number in source file
-  | SrcLoc2	FAST_STRING	-- same, but w/ an Int line#
+  = NoSrcLoc
+
+  | SrcLoc	FAST_STRING	-- A precise location
 		FAST_INT
+
+  | UnhelpfulSrcLoc FAST_STRING	-- Just a general indication
 \end{code}
 
 Note that an entity might be imported via more than one route, and
@@ -57,15 +61,15 @@ rare case.
 
 Things to make 'em:
 \begin{code}
-mkSrcLoc	    = SrcLoc
-mkSrcLoc2 x IBOX(y) = SrcLoc2 x y
-mkUnknownSrcLoc	    = SrcLoc SLIT("<unknown>") SLIT("<unknown>")
-mkIfaceSrcLoc	    = SrcLoc SLIT("<an interface file>") SLIT("<unknown>")
-mkBuiltinSrcLoc	    = SrcLoc SLIT("<built-into-the-compiler>") SLIT("<none>")
-mkGeneratedSrcLoc   = SrcLoc SLIT("<compiler-generated-code>") SLIT("<none>")
-
-unpackSrcLoc (SrcLoc  src_file src_line) = (src_file, src_line)
-unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line)))
+noSrcLoc	    = NoSrcLoc
+mkSrcLoc x IBOX(y)  = SrcLoc x y
+
+mkIfaceSrcLoc	    = UnhelpfulSrcLoc SLIT("<an interface file>")
+mkBuiltinSrcLoc	    = UnhelpfulSrcLoc SLIT("<built-into-the-compiler>")
+mkGeneratedSrcLoc   = UnhelpfulSrcLoc SLIT("<compiler-generated-code>")
+
+isNoSrcLoc NoSrcLoc = True
+isNoSrcLoc other    = False
 \end{code}
 
 %************************************************************************
@@ -77,12 +81,13 @@ unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))
 \begin{code}
 instance Outputable SrcLoc where
     ppr PprForUser (SrcLoc src_file src_line)
-      = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
+      = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ]
 
     ppr sty (SrcLoc src_file src_line)
-      = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
+      = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP,
 		   ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")]
 
-    ppr sty (SrcLoc2 src_file src_line)
-      = ppr sty (SrcLoc src_file (_PK_ (show IBOX(src_line))))
+    ppr sty (UnhelpfulSrcLoc s) = ppPStr s
+
+    ppr sty NoSrcLoc = ppStr "<NoSrcLoc>"
 \end{code}

ghc/compiler/basicTypes/UniqSupply.lhs

@@ -13,7 +13,7 @@ module UniqSupply (
 	getUnique, getUniques,	-- basic ops
 
 	SYN_IE(UniqSM),		-- type: unique supply monad
-	initUs, thenUs, returnUs,
+	initUs, thenUs, returnUs, fixUs,
 	mapUs, mapAndUnzipUs, mapAndUnzip3Us,
 	thenMaybeUs, mapAccumLUs,
 
@@ -147,6 +147,10 @@ initUs init_us m
 
 @thenUs@ is where we split the @UniqSupply@.
 \begin{code}
+fixUs :: (a -> UniqSM a) -> UniqSM a
+fixUs m us
+  = r  where  r = m r us
+
 thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
 
 thenUs expr cont us

ghc/compiler/basicTypes/Unique.lhs

@@ -87,6 +87,7 @@ module Unique (
 	foreignObjTyConKey,
 	forkIdKey,
 	fractionalClassKey,
+	fromEnumClassOpKey,
 	fromIntClassOpKey,
 	fromIntegerClassOpKey,
 	fromRationalClassOpKey,
@@ -212,6 +213,7 @@ module Unique (
 	, parAtRelIdKey
 	, parGlobalIdKey
 	, parLocalIdKey
+	, unboundKey
     ) where
 
 import PreludeGlaST
@@ -664,4 +666,7 @@ eqClassOpKey		= mkPreludeMiscIdUnique 60
 geClassOpKey		= mkPreludeMiscIdUnique 61
 zeroClassOpKey		= mkPreludeMiscIdUnique 62
 thenMClassOpKey		= mkPreludeMiscIdUnique 63 -- (>>=)
+unboundKey		= mkPreludeMiscIdUnique 64	-- Just a place holder for unbound
+							-- variables produced by the renamer
+fromEnumClassOpKey	= mkPreludeMiscIdUnique 65
 \end{code}

ghc/compiler/codeGen/CgBindery.lhs

@@ -44,7 +44,7 @@ import Id		( idPrimRep, toplevelishId, isDataCon,
 			  GenId{-instance NamedThing-}
 			)
 import Maybes		( catMaybes )
-import Name		( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} )
+import Name		( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
 #ifdef DEBUG
 import PprAbsC		( pprAmode )
 #endif
@@ -195,8 +195,8 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@.
 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 
 getCAddrModeAndInfo id
-  | not (isLocallyDefined name) || oddlyImportedName name
-    {- Why the "oddlyImported"?
+  | not (isLocallyDefined name) || isWiredInName name
+    {- Why the "isWiredInName"?
 	Imagine you are compiling GHCbase.hs (a module that
 	supplies some of the wired-in values).  What can
 	happen is that the compiler will inject calls to

ghc/compiler/codeGen/CgClosure.lhs

@@ -26,7 +26,7 @@ import CgBindery	( getCAddrMode, getArgAmodes,
 			  bindNewToReg, bindArgsToRegs,
 			  stableAmodeIdInfo, heapIdInfo, CgIdInfo
 			)
-import CgCompInfo	( spARelToInt, spBRelToInt )
+import Constants	( spARelToInt, spBRelToInt )
 import CgUpdate		( pushUpdateFrame )
 import CgHeapery	( allocDynClosure, heapCheck
 			  , heapCheckOnly, fetchAndReschedule, yield  -- HWL
@@ -41,7 +41,7 @@ import CgUsages		( getVirtSps, setRealAndVirtualSps,
 			  getSpARelOffset, getSpBRelOffset,
 			  getHpRelOffset
 			)
-import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel,
+import CLabel		( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
 			  mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
 			  mkErrorStdEntryLabel, mkRednCountsLabel
 			)
@@ -313,7 +313,8 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
 	-- If f is not top-level, then f is one of the free variables too,
 	-- hence "payload_ids" isn't the same as "arg_ids".
 	--
-	vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
+	stg_args      = map StgVarArg args
+	vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
 									-- Empty live vars
 
 	arg_ids_w_info = [(name,mkLFArgument) | name <- args]
@@ -323,8 +324,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
 	payload_ids | fun_in_payload = fun : args		-- Sigh; needed for mkClosureLFInfo
 		    | otherwise	     = args
 
-	vap_lf_info   = mkClosureLFInfo False {-not top level-} payload_ids
-					upd_flag [] vap_entry_rhs
+	vap_lf_info   = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
 		-- It's not top level, even if we're currently compiling a top-level
 		-- function, because any VAP *use* of this function will be for a
 		-- local thunk, thus
@@ -434,10 +434,6 @@ closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention id lf_info
 		       (map idPrimRep all_args)		`thenFC` \ entry_conv ->
     let
-	is_concurrent = opt_ForConcurrent
-
-	stg_arity = length all_args
-
 	-- Arg mapping for standard (slow) entry point; all args on stack
     	(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
 	   = mkVirtStkOffsets
@@ -510,8 +506,12 @@ closureCodeBody binder_info closure_info cc all_args body
 		    mkIntCLit spA_stk_args,	-- # passed on A stk
 		    mkIntCLit spB_stk_args,	-- B stk (rest in regs)
 		    CString (_PK_ (map (showTypeCategory . idType) all_args)),
-		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
-		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+		    CString SLIT(""), CString SLIT("")
+
+-- Nuked for now; see comment at end of file
+--		    CString (_PK_ (show_wrapper_name wrapper_maybe)),
+--		    CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+
 		]			`thenC`
 
 		-- Bind args to regs/stack as appropriate, and
@@ -544,6 +544,8 @@ closureCodeBody binder_info closure_info cc all_args body
 	CCodeBlock fast_label fast_abs_c
     )
   where
+    is_concurrent = opt_ForConcurrent
+    stg_arity = length all_args
     lf_info = closureLFInfo closure_info
 
     cl_descr mod_name = closureDescription mod_name id all_args body
@@ -554,11 +556,10 @@ closureCodeBody binder_info closure_info cc all_args body
 
 	-- Manufacture labels
     id	       = closureId closure_info
+    fast_label = mkFastEntryLabel id stg_arity
+    stdUpd     = CLbl mkErrorStdEntryLabel CodePtrRep
 
-    fast_label = fastLabelFromCI closure_info
-
-    stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
+{- OLD... see note at end of file
     wrapper_maybe = get_ultimate_wrapper Nothing id
       where
     	get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
@@ -574,6 +575,7 @@ closureCodeBody binder_info closure_info cc all_args body
       = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
 	  Nothing  -> ""
 	  Just str -> str
+-}
 \end{code}
 
 For lexically scoped profiling we have to load the cost centre from
@@ -943,3 +945,46 @@ chooseDynCostCentres cc args fvs body
     in
     (use_cc, blame_cc)
 \end{code}
+
+
+
+========================================================================
+OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
+
+It's pretty wierd, so I've nuked it for now.  SLPJ Nov 96
+
+\begin{pseudocode}
+getWrapperArgTypeCategories
+	:: Type				-- wrapper's type