[project @ 1999-05-18 15:03:33 by simonpj]

RULES-NOTES

8 files changed, 97 insertions, 119 deletions

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index aa09d5db6d..b02e248c1d 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.28 1999/05/13 17:30:55 simonm Exp $
+% $Id: CgCase.lhs,v 1.29 1999/05/18 15:03:46 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -11,8 +11,8 @@
 
 \begin{code}
 module CgCase (	cgCase, saveVolatileVarsAndRegs, 
-		restoreCurrentCostCentre, freeCostCentreSlot,
-		splitTyConAppThroughNewTypes ) where
+		restoreCurrentCostCentre, freeCostCentreSlot
+	) where
 
 #include "HsVersions.h"
 
@@ -25,7 +25,6 @@ import AbsCSyn
 import AbsCUtils	( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
 			  getAmodeRep, nonemptyAbsC
 			)
-import CoreSyn		( isDeadBinder )
 import CgUpdate		( reserveSeqFrame )
 import CgBindery	( getVolatileRegs, getArgAmodes, getArgAmode,
 			  bindNewToReg, bindNewToTemp,
@@ -51,6 +50,7 @@ import CLabel		( CLabel, mkVecTblLabel, mkReturnPtLabel,
 import ClosureInfo	( mkLFArgument )
 import CmdLineOpts	( opt_SccProfilingOn, opt_GranMacros )
 import CostCentre	( CostCentre )
+import CoreSyn		( isDeadBinder )
 import Id		( Id, idPrimRep )
 import DataCon		( DataCon, dataConTag, fIRST_TAG, ConTag,
 			  isUnboxedTupleCon, dataConType )
@@ -63,8 +63,7 @@ import TyCon		( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
 			  isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
 			  tyConDataCons, tyConFamilySize )
 import Type		( Type, typePrimRep, splitAlgTyConApp, 
-			  splitTyConApp_maybe,
-			   splitFunTys, applyTys )
+			  splitTyConApp_maybe, splitRepTyConApp_maybe )
 import Unique           ( Unique, Uniquable(..), mkBuiltinUnique )
 import Maybes		( maybeToBool )
 import Util
@@ -238,10 +237,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
        two bindings pointing at the same stack locn doesn't work (it
        confuses nukeDeadBindings).  Hence, use a new temp.
     -}
-    (if (isDeadBinder bndr)
-	then nopC
-	else bindNewToTemp bndr  `thenFC`  \deflt_amode ->
-	     absC (CAssign deflt_amode amode)) `thenC`
+    bindNewToTemp bndr  		`thenFC`  \deflt_amode ->
+    absC (CAssign deflt_amode amode)	`thenC`
 
     cgPrimAlts NoGC amode alts deflt []
 \end{code}
@@ -448,9 +445,7 @@ cgEvalAlts cc_slot bndr srt alts
       (StgAlgAlts ty alts deflt) ->
 
 	   -- bind the default binder (it covers all the alternatives)
-    	(if (isDeadBinder bndr)
-		then nopC
-		else bindNewToReg bndr node mkLFArgument) `thenC`
+    	bindNewToReg bndr node mkLFArgument	 `thenC`
 
 	-- Generate sequel info for use downstream
 	-- At the moment, we only do it if the type is vector-returnable.
@@ -757,9 +752,7 @@ cgPrimEvalAlts bndr ty alts deflt
 
 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
   = 	-- first bind the default if necessary
-    (if isDeadBinder bndr 
-	then nopC
-	else bindNewPrimToAmode bndr scrutinee) 	`thenC`
+    bindNewPrimToAmode bndr scrutinee	 	`thenC`
     cgPrimAlts gc_flag scrutinee alts deflt regs
 
 cgPrimAlts gc_flag scrutinee alts deflt regs
@@ -988,41 +981,14 @@ possibleHeapCheck NoGC	_ _ tags lbl code
   = code
 \end{code}
 
-splitTyConAppThroughNewTypes is like splitTyConApp_maybe except
-that it looks through newtypes in addition to synonyms.  It's
-useful in the back end where we're not interested in newtypes
-anymore.
-
-Sometimes, we've thrown away the constructors during pruning in the
-renamer.  In these cases, we emit a warning and fall back to using a
-SEQ_FRAME to evaluate the case scrutinee.
-
 \begin{code}
 getScrutineeTyCon :: Type -> Maybe TyCon
 getScrutineeTyCon ty =
-   case (splitTyConAppThroughNewTypes ty) of
+   case splitRepTyConApp_maybe ty of
 	Nothing -> Nothing
 	Just (tc,_) -> 
 		if isFunTyCon tc  then Nothing else     -- not interested in funs
 		if isPrimTyCon tc then Just tc else	-- return primitive tycons
 			-- otherwise (algebraic tycons) check the no. of constructors
-		case (tyConFamilySize tc) of
-			0 -> pprTrace "Warning" (hcat [
-				text "constructors for ",
-				ppr tc,
-				text " not available.\n\tUse -fno-prune-tydecls to fix."
-				]) Nothing
-			_ -> Just tc
-
-splitTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
-splitTyConAppThroughNewTypes ty
-  = case splitTyConApp_maybe ty of
-      Just (tc, tys)
-	| isNewTyCon tc ->  splitTyConAppThroughNewTypes ty
-	| otherwise     ->  Just (tc, tys)
-	where
-	  ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys)
-
-      other  -> Nothing
-
+		Just tc
 \end{code}
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index edcb089862..7d532bad11 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.30 1999/05/13 17:30:56 simonm Exp $
+% $Id: CgClosure.lhs,v 1.31 1999/05/18 15:03:47 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -22,7 +22,6 @@ import {-# SOURCE #-} CgExpr ( cgExpr )
 import CgMonad
 import AbsCSyn
 import StgSyn
-import BasicTypes	( TopLevelFlag(..) )
 
 import AbsCUtils	( mkAbstractCs, getAmodeRep )
 import CgBindery	( getCAddrMode, getArgAmodes,
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 35dcdc2610..6be1371550 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -50,7 +50,6 @@ import Module		( isDynamicModule )
 import Const		( Con(..), Literal(..), isLitLitLit )
 import PrelInfo		( maybeCharLikeCon, maybeIntLikeCon )
 import PrimRep		( PrimRep(..) )
-import BasicTypes	( TopLevelFlag(..) )
 import Util
 import Panic		( assertPanic, trace )
 \end{code}
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 99d286ea7c..6b75ee50d9 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -26,7 +26,6 @@ import Name		( getOccString )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import TyCon		( tyConDataCons, isEnumerationTyCon, TyCon )
 import Type		( typePrimRep, Type )
-import BasicTypes	( TopLevelFlag(..) )
 import Outputable	
 \end{code}
 
@@ -72,15 +71,10 @@ closures predeclared.
 \begin{code}
 genStaticConBits :: CompilationInfo 	-- global info about the compilation
 		 -> [TyCon]		-- tycons to generate
-	  	 -> FiniteMap TyCon [(Bool, [Maybe Type])]
-					-- tycon specialisation info
 		 -> AbstractC		-- output
 
-genStaticConBits comp_info gen_tycons tycon_specs
-  = ASSERT( null (fmToList tycon_specs) )
-	-- We don't do specialised type constructors any more
-
-    -- for each type constructor:
+genStaticConBits comp_info gen_tycons
+  = -- for each type constructor:
     --	 grab all its data constructors;
     --	    for each one, generate an info table
     -- for each specialised type constructor
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 5c4cd9b08a..4490a81748 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.24 1999/05/07 13:44:00 simonm Exp $
+% $Id: CgExpr.lhs,v 1.25 1999/05/18 15:03:49 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -24,8 +24,7 @@ import CLabel		( mkClosureTblLabel )
 import SMRep		( fixedHdrSize )
 import CgBindery	( getArgAmodes, getArgAmode, CgIdInfo, nukeDeadBindings)
 import CgCase		( cgCase, saveVolatileVarsAndRegs, 
-			  restoreCurrentCostCentre, freeCostCentreSlot,
-			  splitTyConAppThroughNewTypes )
+			  restoreCurrentCostCentre, freeCostCentreSlot )
 import CgClosure	( cgRhsClosure, cgStdRhsClosure )
 import CgCon		( buildDynCon, cgReturnDataCon )
 import CgLetNoEscape	( cgLetNoEscapeClosure )
@@ -48,7 +47,7 @@ import PrimOp		( primOpOutOfLine,
 import PrimRep		( getPrimRepSize, PrimRep(..), isFollowableRep )
 import TyCon		( maybeTyConSingleCon,
 			  isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type		( Type, typePrimRep, splitTyConApp_maybe )
+import Type		( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe )
 import Maybes		( assocMaybe, maybeToBool )
 import Unique		( mkBuiltinUnique )
 import BasicTypes	( TopLevelFlag(..), RecFlag(..) )
@@ -463,7 +462,7 @@ primRetUnboxedTuple op args res_ty
       allocate some temporaries for the return values.
     -}
     let
-      (tc,ty_args)      = case splitTyConAppThroughNewTypes res_ty of
+      (tc,ty_args)      = case splitRepTyConApp_maybe res_ty of
 			    Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 			    Just pr -> pr
       prim_reps          = map typePrimRep ty_args
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index dea30bf33d..06a9a52b7d 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgMonad.lhs,v 1.19 1999/05/13 17:30:57 simonm Exp $
+% $Id: CgMonad.lhs,v 1.20 1999/05/18 15:03:49 simonpj Exp $
 %
 \section[CgMonad]{The code generation monad}
 
@@ -29,7 +29,7 @@ module CgMonad (
 
 	StackUsage, HeapUsage,
 
-	profCtrC,
+	profCtrC, cgPanic,
 
 	costCentresC, moduleName,
 
@@ -49,7 +49,7 @@ import {-# SOURCE #-} CgUsages  ( getSpRelOffset )
 import AbsCSyn
 import AbsCUtils	( mkAbsCStmts )
 import CmdLineOpts	( opt_SccProfilingOn, opt_DoTickyProfiling )
-import CLabel           ( CLabel, mkUpdInfoLabel )
+import CLabel           ( CLabel, mkUpdInfoLabel, pprCLabel )
 import Module		( Module )
 import DataCon		( ConTag )
 import Id		( Id )
@@ -177,7 +177,7 @@ sequelToAmode (OnStack virt_sp_offset)
 
 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
 sequelToAmode (CaseAlts amode _) = returnFC amode
-sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
+sequelToAmode (SeqFrame _ _) = cgPanic (text "sequelToAmode: SeqFrame")
 
 type CgStksAndHeapUsage		-- stacks and heap usage information
   = (StackUsage, HeapUsage)
@@ -608,13 +608,17 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
       case (lookupVarEnv static_binds name) of
 	Just this -> this
 	Nothing
-	  -> pprPanic "lookupBindC:no info!\n"
-	     (vcat [
-		hsep [ptext SLIT("for:"), ppr name],
-		ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
+	  -> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
+
+cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
+cgPanic doc info_down@(MkCgInfoDown _ static_binds srt _)
+	    state@(MkCgState absC local_binds usage)
+  = pprPanic "cgPanic"
+	     (vcat [doc,
 		ptext SLIT("static binds for:"),
 		vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
 		ptext SLIT("local binds for:"),
-		vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ]
+		vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ],
+	        ptext SLIT("SRT label") <+> pprCLabel srt
 	      ])
 \end{code}
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 986bfd29ee..3b7b5a1b1b 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: ClosureInfo.lhs,v 1.37 1999/05/11 16:44:02 keithw Exp $
+% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -88,7 +88,7 @@ import PprType		( getTyDescription )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness, PrimRep )
 import SMRep		-- all of it
 import Type		( isUnLiftedType, Type )
-import BasicTypes	( TopLevelFlag(..) )
+import BasicTypes	( TopLevelFlag(..), isNotTopLevel, isTopLevel )
 import Util		( mapAccumL )
 import Outputable
 \end{code}
@@ -543,7 +543,7 @@ nodeMustPointToIt lf_info
   = case lf_info of
 	LFReEntrant ty top arity no_fvs _ _ -> returnFC (
 	    not no_fvs ||   -- Certainly if it has fvs we need to point to it
-	    case top of { TopLevel -> False; _ -> True }
+	    isNotTopLevel top
 		    -- If it is not top level we will point to it
 		    --   We can have a \r closure with no_fvs which
 		    --   is not top level as special case cgRhsClosure
@@ -835,7 +835,7 @@ staticClosureRequired
 	-> Bool
 staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
 		      (LFReEntrant _ top_level _ _ _ _)	-- It's a function
-  = ASSERT( case top_level of { TopLevel -> True; other -> False } )
+  = ASSERT( isTopLevel top_level )
 	-- Assumption: it's a top-level, no-free-var binding
     arg_occ 		-- There's an argument occurrence
     || unsat_occ	-- There's an unsaturated call
@@ -865,7 +865,7 @@ funInfoTableRequired
 	-> Bool
 funInfoTableRequired  binder (StgBinderInfo arg_occ unsat_occ _ _ _)
 		     (LFReEntrant _ top_level _ _ _ _)
-  = (case top_level of { NotTopLevel -> True; TopLevel -> False })
+  =    isNotTopLevel top_level
     || arg_occ 		-- There's an argument occurrence
     || unsat_occ	-- There's an unsaturated call
     || isExternallyVisibleName binder
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index c6d94f465d..35e18cb659 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -24,73 +24,90 @@ import CgMonad
 import AbsCSyn
 import CLabel		( CLabel, mkSRTLabel, mkClosureLabel )
 
-import AbsCUtils	( mkAbstractCs, mkAbsCStmts )
+import PprAbsC		( dumpRealC )
+import AbsCUtils	( mkAbstractCs, mkAbsCStmts, flattenAbsC )
 import CgBindery	( CgIdInfo )
 import CgClosure	( cgTopRhsClosure )
 import CgCon		( cgTopRhsCon )
 import CgConTbls	( genStaticConBits )
 import ClosureInfo	( mkClosureLFInfo )
 import CmdLineOpts	( opt_SccProfilingOn, opt_EnsureSplittableC, 
-					      opt_SccGroup
+			  opt_D_dump_absC,    opt_SccGroup
 			)
 import CostCentre       ( CostCentre, CostCentreStack )
 import FiniteMap	( FiniteMap )
 import Id               ( Id, idName )
-import Module           ( Module, moduleString )
+import Module           ( Module, moduleString, ModuleName, moduleNameString )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import Type             ( Type )
-import TyCon            ( TyCon )
+import TyCon            ( TyCon, isDataTyCon )
+import Class		( Class, classTyCon )
 import BasicTypes	( TopLevelFlag(..) )
+import UniqSupply	( mkSplitUniqSupply )
+import ErrUtils		( dumpIfSet )
 import Util
 import Panic		( assertPanic )
 \end{code}
 
 \begin{code}
-codeGen :: Module		-- module name
-	-> ([CostCentre],	-- local cost-centres needing declaring/registering
+
+
+codeGen :: Module		-- Module name
+	-> [ModuleName]		-- Import names
+	-> ([CostCentre],	-- Local cost-centres needing declaring/registering
 	    [CostCentre],	-- "extern" cost-centres needing declaring
-	    [CostCentreStack])  -- pre-defined "singleton" cost centre stacks
-	-> [Module]		-- import names
-	-> [TyCon]		-- tycons with data constructors to convert
-	-> FiniteMap TyCon [(Bool, [Maybe Type])]
-				-- tycon specialisation info
-	-> [(StgBinding,[Id])]	-- bindings to convert, with SRTs
-	-> AbstractC		-- output
-
-codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) 
-	import_names gen_tycons tycon_specs stg_pgm
-  = let
-	maybe_split       = if opt_EnsureSplittableC 
-				then CSplitMarker 
-				else AbsCNop
-	cinfo             = MkCompInfo mod_name
+	    [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
+	-> [TyCon] -> [Class]	-- Local tycons and classes
+	-> [(StgBinding,[Id])]	-- Bindings to convert, with SRTs
+	-> IO AbstractC		-- Output
+
+codeGen mod_name imported_modules cost_centre_info
+	tycons classes stg_binds
+  = mkSplitUniqSupply 'f'	>>= \ fl_uniqs  -> -- absC flattener
+    let
+	datatype_stuff 	  = genStaticConBits cinfo data_tycons
+	code_stuff     	  = initC cinfo (cgTopBindings maybe_split stg_binds)
+	cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info
+
+	abstractC = mkAbstractCs [ cost_centre_stuff, 
+				   datatype_stuff,
+				   code_stuff ]
+
+	flat_abstractC = flattenAbsC fl_uniqs abstractC
     in
-    let 
-	module_code = mkAbstractCs [
-	    genStaticConBits cinfo gen_tycons tycon_specs,
-	    initC cinfo (cgTopBindings maybe_split stg_pgm) ]
-
-	 -- Cost-centre profiling:
-	 -- Besides the usual stuff, we must produce:
-	 --
-    	 -- * Declarations for the cost-centres defined in this module;
-	 -- * Code to participate in "registering" all the cost-centres
-	 --   in the program (done at startup time when the pgm is run).
-	 --
-	 -- (The local cost-centres involved in this are passed
-	 -- into the code-generator, as are the imported-modules' names.)
-	 --
-	 --
-	cost_centre_stuff 
-		| not opt_SccProfilingOn = AbsCNop
-		| otherwise = mkAbstractCs (
+    dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC)	>>
+    return flat_abstractC
+
+  where
+    data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
+			-- Generate info tables  for the data constrs arising
+			-- from class decls as well
+
+    maybe_split = if opt_EnsureSplittableC 
+		  then CSplitMarker 
+		  else AbsCNop
+    cinfo       = MkCompInfo mod_name
+\end{code}
+
+Cost-centre profiling:
+Besides the usual stuff, we must produce:
+
+* Declarations for the cost-centres defined in this module;
+* Code to participate in "registering" all the cost-centres
+  in the program (done at startup time when the pgm is run).
+
+(The local cost-centres involved in this are passed
+into the code-generator, as are the imported-modules' names.)
+
+\begin{code}
+mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs)
+  | not opt_SccProfilingOn = AbsCNop
+  | otherwise = mkAbstractCs (
 		    map (CCostCentreDecl True)   local_CCs ++
 		    map (CCostCentreDecl False)  extern_CCs ++
 		    map CCostCentreStackDecl     singleton_CCSs ++
 		    mkCcRegister local_CCs singleton_CCSs import_names
-		   )
-   in
-   mkAbstractCs [ cost_centre_stuff, module_code ]
+		)
 
   where
     mkCcRegister ccs cc_stacks import_names
@@ -117,7 +134,7 @@ codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs)
 
 	mk_import_register import_name
 	  = CCallProfCCMacro SLIT("REGISTER_IMPORT") 
-	      [CLitLit (_PK_ ("_reg" ++ moduleString import_name)) AddrRep]
+	      [CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep]
 \end{code}
 
 %************************************************************************