[project @ 2001-03-13 12:50:29 by simonmar]

Some rearrangements that Simon & I have been working on recently:

    - CoreSat is now CorePrep, and is a general "prepare-for-code-
      generation" pass.  It does cloning, saturation of constructors &
      primops, A-normal form, and a couple of other minor fiddlings.

    - CoreTidy no longer does cloning, and minor fiddlings.  It doesn't
      need the unique supply any more, so that's removed.

    - CoreToStg now collects CafInfo and the list of CafRefs for each
      binding.  The SRT pass is much simpler now.

    - IdInfo now has a CgInfo field for "code generator info".  It currently
      contains arity (the actual code gen arity which affects the calling
      convention as opposed to the ArityInfo which is a measure of how
      many arguments the Id can be applied to before it does any work), and
      CafInfo.

      Previously we overloaded the ArityInfo field to contain both
      codegen arity and simplifier arity.  Things are cleaner now.

    - CgInfo is collected by CoreToStg, and passed back into CoreTidy in
      a loop.  The compiler will complain rather than going into a black
      hole if the CgInfo is pulled on too early.

    - Worker info in an interface file now comes with arity info attached.
      Previously the main arity info was overloaded for this purpose, but
      it lead to a few hacks in the compiler, this tidies things up somewhat.

Bottom line: we removed several fragilities, and tidied up a number of
things.  Code size should be smaller, but we'll see...

3 files changed, 36 insertions, 39 deletions

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 7f01cd99f4..a47eb92b50 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.41 2001/02/20 09:38:59 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -208,14 +208,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts)
 \subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
 
 \begin{code}
-cgExpr (StgLet (StgNonRec name rhs) expr)
-  = cgRhs name rhs	`thenFC` \ (name, info) ->
+cgExpr (StgLet (StgNonRec srt name rhs) expr)
+  = cgRhs srt name rhs	`thenFC` \ (name, info) ->
     addBindC name info 	`thenC`
     cgExpr expr
 
-cgExpr (StgLet (StgRec pairs) expr)
+cgExpr (StgLet (StgRec srt pairs) expr)
   = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
-			    listFCs [ cgRhs b e | (b,e) <- pairs ]
+			    listFCs [ cgRhs srt b e | (b,e) <- pairs ]
     ) `thenFC` \ new_bindings ->
 
     addBindsC new_bindings `thenC`
@@ -274,17 +274,15 @@ We rely on the support code in @CgCon@ (to do constructors) and
 in @CgClosure@ (to do closures).
 
 \begin{code}
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
 	-- the Id is passed along so a binding can be set up
 
-cgRhs name (StgRhsCon maybe_cc con args)
+cgRhs srt name (StgRhsCon maybe_cc con args)
   = getArgAmodes args				`thenFC` \ amodes ->
     buildDynCon name maybe_cc con amodes	`thenFC` \ idinfo ->
     returnFC (name, idinfo)
 
-cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
-  = mkRhsClosure name cc bi srt fvs upd_flag args body
-cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
+cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
   = mkRhsClosure name cc bi srt fvs upd_flag args body
 \end{code}
 
@@ -391,17 +389,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body
 %*							*
 %********************************************************
 \begin{code}
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot 
+	(StgNonRec srt binder rhs)
   = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot 	
-			NonRecursive binder rhs 
+			NonRecursive srt binder rhs 
     	    	    	    	`thenFC` \ (binder, info) ->
     addBindC binder info
 
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot 
+	(StgRec srt pairs)
   = fixC (\ new_bindings ->
 		addBindsC new_bindings 	`thenC`
 		listFCs [ cgLetNoEscapeRhs full_live_in_rhss 
-				rhs_eob_info maybe_cc_slot Recursive b e 
+				rhs_eob_info maybe_cc_slot Recursive srt b e 
 			| (b,e) <- pairs ]
     ) `thenFC` \ new_bindings ->
 
@@ -416,25 +416,27 @@ cgLetNoEscapeRhs
     -> EndOfBlockInfo
     -> Maybe VirtualSpOffset
     -> RecFlag
+    -> SRT
     -> Id
     -> StgRhs
     -> FCode (Id, CgIdInfo)
 
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
-		 (StgRhsClosure cc bi srt _ upd_flag args body)
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
+		 (StgRhsClosure cc bi _ upd_flag args body)
   = -- We could check the update flag, but currently we don't switch it off
     -- for let-no-escaped things, so we omit the check too!
     -- case upd_flag of
     --     Updatable -> panic "cgLetNoEscapeRhs"	-- Nothing to update!
     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
-    cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
+    cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
+	maybe_cc_slot rec args body
 
 -- For a constructor RHS we want to generate a single chunk of code which
 -- can be jumped to from many places, which will return the constructor.
 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
     	    	 (StgRhsCon cc con args)
-  = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT 
+  = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
 			 full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 	[] 	--No args; the binder is data structure, not a function
 	(StgConApp con args)
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index d1a40acb24..467f44b036 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.45 2001/02/20 09:38:59 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -79,7 +79,7 @@ import CLabel		( CLabel, mkStdEntryLabel, mkFastEntryLabel,
 import CmdLineOpts	( opt_SccProfilingOn, opt_OmitBlackHoling,
 			  opt_Parallel, opt_DoTickyProfiling,
 			  opt_SMP )
-import Id		( Id, idType, idArityInfo )
+import Id		( Id, idType, idCgArity )
 import DataCon		( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
 			  isNullaryDataCon, dataConName
 			)
@@ -261,16 +261,11 @@ mkLFLetNoEscape = LFLetNoEscape
 
 mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id
-  = case idArityInfo id of
-      ArityExactly 0	-> LFThunk (idType id)
-				TopLevel True{-no fvs-}
-				True{-updatable-} NonStandardThunk
-				(error "mkLFImported: no srt label") 
-				(error "mkLFImported: no srt")
-      ArityExactly n	-> LFReEntrant (idType id) TopLevel n True  -- n > 0
-				(error "mkLFImported: no srt label") 
-				(error "mkLFImported: no srt")
-      other	   	-> LFImported	-- Not sure of exact arity
+  = case idCgArity id of
+      n | n > 0 -> LFReEntrant (idType id) TopLevel n True  -- n > 0
+		       (error "mkLFImported: no srt label") 
+		       (error "mkLFImported: no srt")
+      other -> LFImported	-- Not sure of exact arity
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index bf6177df7f..5db06d0bb4 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -188,7 +188,7 @@ variable.
 
 \begin{code}
 cgTopBinding :: (StgBinding,[Id]) -> Code
-cgTopBinding (StgNonRec id rhs, srt)
+cgTopBinding (StgNonRec srt_info id rhs, srt)
   = absC maybeSplitCode	  	`thenC`
     maybeGlobaliseId id		`thenFC` \ id' ->
     let
@@ -196,11 +196,11 @@ cgTopBinding (StgNonRec id rhs, srt)
     in
     mkSRT srt_label srt [] 	`thenC`
     setSRTLabel srt_label (
-    cgTopRhs id' rhs	  	`thenFC` \ (id, info) ->
+    cgTopRhs id' rhs srt_info  	`thenFC` \ (id, info) ->
     addBindC id info
     )
 
-cgTopBinding (StgRec pairs, srt)
+cgTopBinding (StgRec srt_info pairs, srt)
   = absC maybeSplitCode		  	`thenC`
     let
         (bndrs, rhss) = unzip pairs
@@ -214,7 +214,7 @@ cgTopBinding (StgRec pairs, srt)
     setSRTLabel srt_label (
        fixC (\ new_binds -> 
 		addBindsC new_binds		`thenC`
-		mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+		mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
        )  `thenFC` \ new_binds -> nopC
     )
 
@@ -256,18 +256,18 @@ maybeSplitCode
 -- to enclose the listFCs in cgTopBinding, but that tickled the
 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
 	-- the Id is passed along for setting up a binding...
 
-cgTopRhs bndr (StgRhsCon cc con args)
+cgTopRhs bndr (StgRhsCon cc con args) srt
   = maybeGlobaliseId bndr `thenFC` \ bndr' ->
     forkStatics (cgTopRhsCon bndr con args)
 
-cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
+cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
   =     -- There should be no free variables
     ASSERT(null fvs)
 	-- If the closure is a thunk, then the binder must be recorded as such.
-    ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
+--    ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
 
     getSRTLabel `thenFC` \srt_label ->
     let lf_info =