[project @ 1996-04-30 17:34:02 by partain]

SLPJ 1.3 changes to 960430

ghc/compiler/Jmakefile

@@ -503,7 +503,7 @@ types/TyLoop.hi : types/TyLoop.lhi
 
 rename/ParseIface.hs : rename/ParseIface.y
 	$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
-	happy -i rename/ParseIface.hinfo rename/ParseIface.y
+	happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
 	@chmod 444 rename/ParseIface.hs
 
 compile(absCSyn/AbsCUtils,lhs,)

ghc/compiler/basicTypes/Id.lhs

@@ -81,6 +81,8 @@ module Id {- (
 	showId,
 	pprIdInUnfolding,
 
+	nmbrId,
+
 	-- "Environments" keyed off of Ids, and sets of Ids
 	IdEnv(..),
 	lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
@@ -104,15 +106,17 @@ import Maybes		( maybeToBool )
 import Name		( appendRdr, nameUnique, mkLocalName, isLocalName,
 			  isLocallyDefinedName, isPreludeDefinedName,
 			  mkTupleDataConName, mkCompoundName,
-			  isLexSym, getLocalName,
+			  isLexSym, isLexSpecialSym, getLocalName,
 			  isLocallyDefined, isPreludeDefined,
 			  getOccName, moduleNamePair, origName, nameOf, 
 			  isExported, ExportFlag(..),
 			  RdrName(..), Name
 			)
-import FieldLabel	( fieldLabelName, FieldLabel{-instances-} )
+import FieldLabel	( fieldLabelName, FieldLabel(..){-instances-} )
 import PragmaInfo	( PragmaInfo(..) )
+import PprEnv		-- ( NmbrM(..), NmbrEnv(..) )
 import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
+			  nmbrType, addTyVar,
 			  GenType, GenTyVar
 			)
 import PprStyle
@@ -127,8 +131,8 @@ import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 import TyVar		( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
 import UniqFM
 import UniqSet		-- practically all of it
-import UniqSupply	( getBuiltinUniques )
-import Unique		( pprUnique, showUnique,
+import Unique		( getBuiltinUniques, pprUnique, showUnique,
+			  incrUnique,
 			  Unique{-instance Ord3-}
 			)
 import Util		( mapAccumL, nOfThem, zipEqual,
@@ -656,7 +660,7 @@ pprIdInUnfolding in_scopes v
 	    (m_str, n_str) = moduleNamePair v
 
 	    pp_n =
-	      if isLexSym n_str then
+	      if isLexSym n_str && not (isLexSpecialSym n_str) then
 		  ppBesides [ppLparen, ppPStr n_str, ppRparen]
 	      else
 		  ppPStr n_str
@@ -1938,3 +1942,69 @@ minusIdSet	= minusUniqSet
 isEmptyIdSet	= isEmptyUniqSet
 mkIdSet		= mkUniqSet
 \end{code}
+
+\begin{code}
+addId, nmbrId :: Id -> NmbrM Id
+
+addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+  = case (lookupUFM_Directly idenv u) of
+      Just xx -> _trace "addId: already in map!" $
+		 (nenv, xx)
+      Nothing ->
+	if toplevelishId id then
+	    _trace "addId: can't add toplevelish!" $
+	    (nenv, id)
+	else -- alloc a new unique for this guy
+	     -- and add an entry in the idenv
+	     -- NB: *** KNOT-TYING ***
+	    let
+		nenv_plus_id	= NmbrEnv (incrUnique ui) ut uu
+					  (addToUFM_Directly idenv u new_id)
+					  tvenv uvenv
+
+		(nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
+		(nenv3, new_det) = nmbr_details det nenv2
+
+		new_id = Id ui new_ty new_det prag info
+	    in
+	    (nenv3, new_id)
+
+nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+  = case (lookupUFM_Directly idenv u) of
+      Just xx -> (nenv, xx)
+      Nothing ->
+	if not (toplevelishId id) then
+	    _trace "nmbrId: lookup failed" $
+	    (nenv, id)
+	else
+	    let
+		(nenv2, new_ty)  = nmbrType     ty  nenv
+		(nenv3, new_det) = nmbr_details det nenv2
+
+		new_id = Id u new_ty new_det prag info
+	    in
+	    (nenv3, new_id)
+
+------------
+nmbr_details :: IdDetails -> NmbrM IdDetails
+
+nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
+  = mapNmbr addTyVar   tvs	`thenNmbr` \ new_tvs ->
+    mapNmbr nmbrField  fields	`thenNmbr` \ new_fields ->
+    mapNmbr nmbr_theta theta	`thenNmbr` \ new_theta ->
+    mapNmbr nmbrType   arg_tys	`thenNmbr` \ new_arg_tys ->
+    returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
+  where
+    nmbr_theta (c,t)
+      = --nmbrClass c	`thenNmbr` \ new_c ->
+        nmbrType  t	`thenNmbr` \ new_t ->
+	returnNmbr (c, new_t)
+
+    -- ToDo:add more cases as needed
+nmbr_details other_details = returnNmbr other_details
+
+------------
+nmbrField (FieldLabel n ty tag)
+  = nmbrType ty `thenNmbr` \ new_ty ->
+    returnNmbr (FieldLabel n new_ty tag)
+\end{code}

ghc/compiler/basicTypes/IdLoop.lhi

@@ -11,7 +11,7 @@ import CoreSyn		( CoreExpr(..), GenCoreExpr, GenCoreArg )
 import CoreUnfold 	( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
 import CoreUtils	( unTagBinders )
 import Id		( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
-			  unfoldingUnfriendlyId, getIdInfo,
+			  unfoldingUnfriendlyId, getIdInfo, nmbrId,
 			  nullIdEnv, lookupIdEnv, IdEnv(..),
 			  Id(..), GenId
 			)
@@ -19,6 +19,7 @@ import IdInfo		( IdInfo )
 import Literal		( Literal )
 import MagicUFs		( mkMagicUnfoldingFun, MagicUnfoldingFun )
 import Outputable	( Outputable(..) )
+import PprEnv		( NmbrEnv )
 import PprStyle		( PprStyle )
 import PprType		( pprParendGenType )
 import Pretty		( PrettyRep )
@@ -39,6 +40,7 @@ getIdInfo		:: Id	    -> IdInfo
 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
 
@@ -58,6 +60,7 @@ instance Outputable (GenTyVar a)
 instance (Outputable a) => Outputable (GenId a)
 instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
 
+data NmbrEnv
 data MagicUnfoldingFun
 data FormSummary   = WhnfForm | BottomForm | OtherForm
 data UnfoldingDetails

ghc/compiler/basicTypes/IdUtils.lhs

@@ -43,7 +43,7 @@ primOpId op
       Compare str ty ->
 	mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
 
-      Coerce str ty1 ty2 ->
+      Coercing str ty1 ty2 ->
 	mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
 
       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->

ghc/compiler/basicTypes/Name.lhs

@@ -48,7 +48,7 @@ module Name (
 	getLocalName, ltLexical,
 
 	isSymLexeme, pprSym, pprNonSym,
-	isLexCon, isLexVar, isLexId, isLexSym,
+	isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
 	isLexConId, isLexConSym, isLexVarId, isLexVarSym
     ) where
 
@@ -123,7 +123,6 @@ instance Outputable RdrName where
     ppr sty (Unqual n) = pp_name sty n
     ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
 
-pp_mod PprInterface        m = ppNil
 pp_mod PprForC             m = ppBesides [identToC m, ppPStr cSEP]
 pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
 pp_mod (PprForAsm True  _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
@@ -423,7 +422,8 @@ defined in the Haskell report.  Normally applied as in e.g. @isCon
 (getLocalName foo)@.
 
 \begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
 
 isLexCon cs = isLexConId  cs || isLexConSym cs
 isLexVar cs = isLexVarId  cs || isLexVarSym cs
@@ -450,9 +450,9 @@ isLexVarId cs
 isLexConSym cs
   | _NULL_ cs	= False
   | otherwise	= c  == ':'
-	       || c == '('	-- (), (,), (,,), ...
+--	       || c  == '('	-- (), (,), (,,), ...
 	       || cs == SLIT("->")
-	       || cs == SLIT("[]")
+--	       || cs == SLIT("[]")
   where
     c = _HEAD_ cs
 
@@ -460,7 +460,14 @@ isLexVarSym cs
   | _NULL_ cs = False
   | otherwise = isSymbolASCII c
 	     || isSymbolISO c
-	     || c == '('	-- (), (,), (,,), ...
+--	     || c  == '('	-- (), (,), (,,), ...
+--	     || cs == SLIT("[]")
+  where
+    c = _HEAD_ cs
+
+isLexSpecialSym cs
+  | _NULL_ cs = False
+  | otherwise = c  == '('	-- (), (,), (,,), ...
 	     || cs == SLIT("[]")
   where
     c = _HEAD_ cs
@@ -484,13 +491,16 @@ isSymLexeme v
 pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
 
 pprSym sty var
-  = if isSymLexeme var
+  = let
+	str = nameOf (origName var)
+    in
+    if isLexSym str && not (isLexSpecialSym str)
     then ppr sty var
     else ppBesides [ppChar '`', ppr sty var, ppChar '`']
 
 pprNonSym sty var
   = if isSymLexeme var
-    then ppBesides [ppLparen, ppr sty var, ppRparen]
+    then ppParens (ppr sty var)
     else ppr sty var
 
 #ifdef USE_ATTACK_PRAGMAS

ghc/compiler/basicTypes/PprEnv.lhs

@@ -12,13 +12,22 @@ module PprEnv (
 	initPprEnv,
 
 	pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
-	pTy, pTyVar, pUVar, pUse
+	pTy, pTyVar, pUVar, pUse,
+	
+	NmbrEnv(..),
+	NmbrM(..), initNmbr,
+	returnNmbr, thenNmbr,
+	mapNmbr, mapAndUnzipNmbr
+--	nmbr1, nmbr2, nmbr3
+--	rnumValVar,   rnumTyVar,   rnumUVar,
+--	lookupValVar, lookupTyVar, lookupUVar
     ) where
 
 import Ubiq{-uitous-}
 
-import Id		( DataCon(..) )
 import Pretty		( Pretty(..) )
+import Unique		( initRenumberingUniques )
+import UniqFM		( emptyUFM )
 import Util		( panic )
 \end{code}
 
@@ -32,7 +41,7 @@ data PprEnv tyvar uvar bndr occ
   = PE	PprStyle		-- stored for safe keeping
 
 	(Literal    -> Pretty)	-- Doing these this way saves
-	(DataCon    -> Pretty)	-- carrying around a PprStyle
+	(Id    -> Pretty)	-- carrying around a PprStyle
 	(PrimOp     -> Pretty)
 	(CostCentre -> Pretty)
 
@@ -51,7 +60,7 @@ data PprEnv tyvar uvar bndr occ
 initPprEnv
 	:: PprStyle
 	-> Maybe (Literal -> Pretty)
-	-> Maybe (DataCon -> Pretty)
+	-> Maybe (Id -> Pretty)
 	-> Maybe (PrimOp  -> Pretty)
 	-> Maybe (CostCentre -> Pretty)
 	-> Maybe (tyvar -> Pretty)
@@ -119,3 +128,75 @@ pOcc     (PE _	_  _  _  _  _  _  _  _ pp  _  _) = pp
 pTy      (PE _	_  _  _  _  _  _  _  _  _ pp  _) = pp
 pUse	 (PE _	_  _  _  _  _  _  _  _  _  _ pp) = pp
 \end{code}
+
+We tend to {\em renumber} everything before printing, so that
+we get consistent Uniques on everything from run to run.
+\begin{code}
+data NmbrEnv
+  = NmbrEnv	Unique	-- next "Unique" to give out for a value
+		Unique	-- ... for a tyvar
+		Unique	-- ... for a usage var
+		(UniqFM Id)	-- mapping for value vars we know about
+		(UniqFM TyVar)	-- ... for tyvars
+		(UniqFM Unique{-UVar-})	-- ... for usage vars
+
+type NmbrM a = NmbrEnv -> (NmbrEnv, a)
+
+initNmbr :: NmbrM a -> a
+initNmbr m
+  = let
+	(v1,t1,u1)    = initRenumberingUniques
+	init_nmbr_env = NmbrEnv v1 t1 u1 emptyUFM emptyUFM emptyUFM
+    in
+    snd (m init_nmbr_env)
+
+returnNmbr x nenv = (nenv, x)
+
+thenNmbr m k nenv
+  = let
+	(nenv2, res) = m nenv
+    in
+    k res nenv2
+
+mapNmbr f []     = returnNmbr []
+mapNmbr f (x:xs)
+  = f x		    `thenNmbr` \ r  ->
+    mapNmbr f xs    `thenNmbr` \ rs ->
+    returnNmbr (r:rs)
+
+mapAndUnzipNmbr f [] = returnNmbr ([],[])
+mapAndUnzipNmbr f (x:xs)
+  = f x			    `thenNmbr` \ (r1,  r2)  ->
+    mapAndUnzipNmbr f xs    `thenNmbr` \ (rs1, rs2) ->
+    returnNmbr (r1:rs1, r2:rs2)
+
+{-
+nmbr1 nenv thing x1
+  = let
+	(nenv1, new_x1) = x1 nenv
+    in
+    (nenv1, thing new_x1)
+
+nmbr2 nenv thing x1 x2
+  = let
+	(nenv1, new_x1) = x1 nenv
+	(nenv2, new_x2) = x2 nenv1
+    in
+    (nenv2, thing new_x1 new_x2)
+
+nmbr3 nenv thing x1 x2 x3
+  = let
+	(nenv1, new_x1) = x1 nenv
+	(nenv2, new_x2) = x2 nenv1
+	(nenv3, new_x3) = x3 nenv2
+    in
+    (nenv3, thing new_x1 new_x2 new_x3)
+-}
+
+rnumValVar = panic "rnumValVar"
+rnumTyVar = panic "rnumTyVar"
+rnumUVar = panic "rnumUVar"
+lookupValVar = panic "lookupValVar"
+lookupTyVar = panic "lookupTyVar"
+lookupUVar = panic "lookupUVar"
+\end{code}

ghc/compiler/basicTypes/UniqSupply.lhs

@@ -18,11 +18,7 @@ module UniqSupply (
 	thenMaybeUs, mapAccumLUs,
 
 	mkSplitUniqSupply,
-	splitUniqSupply,
-
-	-- and the access functions for the `builtin' UniqueSupply
-	getBuiltinUniques, mkBuiltinUnique,
-	mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+	splitUniqSupply
   ) where
 
 import Ubiq{-uitous-}
@@ -190,28 +186,3 @@ mapAccumLUs f b (x:xs)
     mapAccumLUs f b__2 xs   	    `thenUs` \ (b__3, xs__2) ->
     returnUs (b__3, x__2:xs__2)
 \end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
-%*									*
-%************************************************************************
-
-\begin{code}
-mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- mkBuiltinUnique :: Int -> Unique
-
-mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
-mkPseudoUnique2 i = mkUnique 'D' i -- ditto
-mkPseudoUnique3 i = mkUnique 'E' i -- ditto
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-\end{code}
-
-The following runs a uniq monad expression, using builtin uniq values:
-\begin{code}
---runBuiltinUs :: UniqSM a -> a
---runBuiltinUs m = snd (initUs uniqSupply_B m)
-\end{code}

ghc/compiler/basicTypes/Unique.lhs

@@ -29,6 +29,9 @@ module Unique (
 	mkUnique,			-- Used in UniqSupply
 	mkUniqueGrimily,		-- Used in UniqSupply only!
 
+	incrUnique,			-- Used for renumbering
+	initRenumberingUniques,
+
 	-- now all the built-in Uniques (and functions to make them)
 	-- [the Oh-So-Wonderful Haskell module system wins again...]
 	mkAlphaTyVarUnique,
@@ -36,6 +39,9 @@ module Unique (
 	mkTupleDataConUnique,
 	mkTupleTyConUnique,
 
+	getBuiltinUniques, mkBuiltinUnique,
+	mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+
 	absentErrorIdKey,	-- alphabetical...
 	addrDataConKey,
 	addrPrimTyConKey,
@@ -227,22 +233,16 @@ The stuff about unique *supplies* is handled further down this module.
 mkUnique	:: Char -> Int -> Unique	-- Builds a unique from pieces
 unpkUnique	:: Unique -> (Char, Int)	-- The reverse
 
-mkUnifiableTyVarUnique	 :: Int -> Unique	-- Injects a subst-array index into the Unique type
-unpkUnifiableTyVarUnique :: Unique -> Int	-- The reverse process
-
 mkUniqueGrimily :: Int# -> Unique		-- A trap-door for UniqSupply
+
+incrUnique	:: Unique -> Unique
 \end{code}
 
 
 \begin{code}
 mkUniqueGrimily x = MkUnique x
 
-mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i
-
-unpkUnifiableTyVarUnique uniq
-  = case (unpkUnique uniq) of { (tag, i) ->
-    ASSERT(tag == '_'{-MAGIC CHAR-})
-    i }
+incrUnique (MkUnique i) = MkUnique (i +# 1#)
 
 -- pop the Char in the top 8 bits of the Unique(Supply)
 
@@ -375,9 +375,10 @@ chars62
 %************************************************************************
 
 Allocation of unique supply characters:
-	a-z: lower case chars for unique supplies (see Main.lhs)
-	B:   builtin		(see UniqSupply.lhs)
-	C-E: pseudo uniques	(see UniqSupply.lhs)
+	v,t,u : for renumbering value-, type- and usage- vars.
+	other a-z: lower case chars for unique supplies (see Main.lhs)
+	B:   builtin
+	C-E: pseudo uniques	(used in native-code generator)
 	_:   unifiable tyvars   (above)
 	1-8: prelude things below
 
@@ -393,6 +394,19 @@ mkTupleDataConUnique a		= mkUnique '6' a	-- ditto (*may* be used in C labels)
 
 mkPrimOpIdUnique op		= mkUnique '7' op
 mkPreludeMiscIdUnique i		= mkUnique '8' i
+
+initRenumberingUniques = (mkUnique 'v' 1, mkUnique 't' 1, mkUnique 'u' 1)
+
+mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ mkBuiltinUnique :: Int -> Unique
+
+mkBuiltinUnique i = mkUnique 'B' i
+mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
+mkPseudoUnique2 i = mkUnique 'D' i -- ditto
+mkPseudoUnique3 i = mkUnique 'E' i -- ditto
+
+getBuiltinUniques :: Int -> [Unique]
+getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
 \end{code}
 
 %************************************************************************

ghc/compiler/codeGen/ClosureInfo.lhs

@@ -92,7 +92,7 @@ import PprType		( GenType{-instance Outputable-} )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness )
 import SMRep		-- all of it
 import TyCon		( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type		( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
+import Type		( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
 import Util		( isIn, mapAccumL, panic, pprPanic, assertPanic )
 
 maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
@@ -1163,7 +1163,7 @@ closureReturnsUnboxedType other_closure = False
 fun_result_ty arity id
   = let
 	(_, de_foralld_ty) = splitForAllTy (idType id)