X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgCon.lhs;h=cb5337be61eb8ab14c3d2b7e85b1a7dbbda5ab83;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=05ef0e81ecdb31c52c5bea28f17ee79c2cd8aba5;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 05ef0e8..cb5337b 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
 %
 \section[CgCon]{Code generation for constructors}
 
@@ -11,62 +11,48 @@ with {\em constructors} on the RHSs of let(rec)s.  See also
 #include "HsVersions.h"
 
 module CgCon (
-	-- it's all exported, actually...
 	cgTopRhsCon, buildDynCon,
 	bindConArgs,
-	cgReturnDataCon,
-
-	-- and to make the interface self-sufficient...
-	Id, StgAtom, CgState, CAddrMode,
-	PrimKind, PrimOp, MagicId
+	cgReturnDataCon
     ) where
 
-IMPORT_Trace		-- ToDo: rm (debugging)
-import Outputable
-import Pretty
+IMP_Ubiq(){-uitous-}
 
-import StgSyn
 import CgMonad
 import AbsCSyn
+import StgSyn
 
-import AbsUniType	( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
-			  TyCon, Class, UniType
-			)
-import CgBindery	( getAtomAmode, getAtomAmodes, bindNewToNode,
-			  bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import AbsCUtils	( mkAbstractCs, getAmodeRep )
+import CgBindery	( getArgAmodes, bindNewToNode,
+			  bindArgsToRegs, newTempAmodeAndIdInfo,
+			  idInfoToAmode, stableAmodeIdInfo,
+			  heapIdInfo
 			)
 import CgClosure	( cgTopRhsClosure )
-import CgHeapery	( allocDynClosure, heapCheck
-#ifdef GRAN
-			  , fetchAndReschedule  -- HWL
-#endif  {- GRAN -}
-			)
 import CgCompInfo	( mAX_INTLIKE, mIN_INTLIKE )
-
-import CgRetConv	( dataReturnConvAlg, mkLiveRegsBitMask,
-			  CtrlReturnConvention(..), DataReturnConvention(..)
-			)
+import CgHeapery	( allocDynClosure )
+import CgRetConv	( dataReturnConvAlg, DataReturnConvention(..) )
 import CgTailCall	( performReturn, mkStaticAlgReturnCode )
-import CgUsages		( getHpRelOffset )
-import CLabelInfo	( CLabel, mkClosureLabel, mkInfoTableLabel,
-                          mkPhantomInfoTableLabel,
-			  mkConEntryLabel, mkStdEntryLabel
+import CLabel		( mkClosureLabel, mkStaticClosureLabel,
+			  mkConInfoTableLabel, mkPhantomInfoTableLabel
 			)
-import ClosureInfo	-- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
-			{-( mkConLFInfo, mkLFArgument, closureLFInfo,
+import ClosureInfo	( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
 			  layOutDynCon, layOutDynClosure,
-			  layOutStaticClosure, UpdateFlag(..),
-			  mkClosureLFInfo, layOutStaticNoFVClosure
-			)-}
-import Id		( getIdKind, getDataConTag, getDataConTyCon,
-			  isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+			  layOutStaticClosure
+			)
+import CostCentre	( currentOrSubsumedCosts, useCurrentCostCentre,
+			  dontCareCostCentre
 			)
-import CmdLineOpts	( GlobalSwitch(..) )
-import Maybes		( maybeToBool, Maybe(..) )
-import PrimKind		( PrimKind(..), isFloatingKind, getKindSize )
-import CostCentre
-import UniqSet		-- ( emptyUniqSet, UniqSet(..) )
-import Util
+import Id		( idPrimRep, dataConTag, dataConTyCon,
+			  isDataCon, DataCon(..),
+			  emptyIdSet
+			)
+import Literal		( Literal(..) )
+import Maybes		( maybeToBool )
+import PrelInfo		( maybeCharLikeTyCon, maybeIntLikeTyCon )
+import PrimRep		( isFloatingRep, PrimRep(..) )
+import TyCon		( TyCon{-instance Uniquable-} )
+import Util		( isIn, zipWithEqual, panic, assertPanic )
 \end{code}
 
 %************************************************************************
@@ -78,12 +64,12 @@ import Util
 \begin{code}
 cgTopRhsCon :: Id		-- Name of thing bound to this RHS
 	    -> DataCon		-- Id
-	    -> [PlainStgAtom]	-- Args
+	    -> [StgArg]		-- Args
 	    -> Bool		-- All zero-size args (see buildDynCon)
 	    -> FCode (Id, CgIdInfo)
 \end{code}
 
-Special Case: 
+Special Case:
 Constructors some of whose arguments are of \tr{Float#} or
 \tr{Double#} type, {\em or} which are ``lit lits'' (which are given
 \tr{Addr#} type).
@@ -106,7 +92,7 @@ Thus, for \tr{x = 2.0} (defaults to Double), we get:
     STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double");
 -- with its *own* entry code:
     STGFUN(Main_x_entry) {
-        P_ u1701;
+	P_ u1701;
 	RetDouble1=2.0;
 	u1701=(P_)*SpB;
 	SpB=SpB-1;
@@ -133,11 +119,11 @@ top_cc  = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh)
 top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data
 
 cgTopRhsCon name con args all_zero_size_args
-  |  any (isFloatingKind . getAtomKind) args
-  || any isLitLitStgAtom args
+  |  any (isFloatingRep . getArgPrimRep) args
+  || any isLitLitArg args
   = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
   where
-    body = StgConApp con args emptyUniqSet{-emptyLiveVarSet-}
+    body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
     lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
 \end{code}
 
@@ -149,11 +135,11 @@ cgTopRhsCon name con args all_zero_size_args
     ASSERT(isDataCon con)
 
 	-- LAY IT OUT
-    getAtomAmodes args		`thenFC` \ amodes ->
+    getArgAmodes args		`thenFC` \ amodes ->
 
     let
 	(closure_info, amodes_w_offsets)
-	  = layOutStaticClosure name getAmodeKind amodes lf_info
+	  = layOutStaticClosure name getAmodeRep amodes lf_info
     in
 	-- HWL: In 0.22 there was a heap check in here that had to be changed.
 	--      CHECK if having no heap check is ok for GrAnSim here!!!
@@ -168,15 +154,11 @@ cgTopRhsCon name con args all_zero_size_args
     ) `thenC`
 
 	-- RETURN
-    returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
+    returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
   where
-    con_tycon	    = getDataConTyCon con
-    lf_info	    = mkConLFInfo con
-
-    closure_label   = mkClosureLabel  name
-    info_label      = mkInfoTableLabel con
-    con_entry_label = mkConEntryLabel con
-    entry_label	    = mkStdEntryLabel name
+    con_tycon	    = dataConTyCon   con
+    lf_info	    = mkConLFInfo    con
+    closure_label   = mkClosureLabel name
 \end{code}
 
 The general case is:
@@ -207,8 +189,6 @@ regular \tr{MkFoo} info-table and entry code.  (2)~However: the
 will not have set it.  Therefore, the whole point of \tr{x_entry} is
 to set node (and then call the shared \tr{MkFoo} entry code).
 
-
-
 Special Case:
 For top-level Int/Char constants. We get entry-code fragments of the form:
 
@@ -252,62 +232,10 @@ STG syntax:
     }
 \end{verbatim}
 
-This blob used to be in cgTopRhsCon, but I don't see how we can
-jump direct to the named code for a constructor; any external entries
-will be via Node.  Generating all this extra code is a real waste 
-for big static data structures.  So I've nuked it.  SLPJ Sept 94
-
-
-Further discourse on these entry-code fragments (NB this isn't done
-yet [ToDo]): They're really pretty pointless, except for {\em
-exported} top-level constants (the rare case).  Consider:
-\begin{verbatim}
-y = p : ps	-- y is not exported
-f a b = y
-g c = (y, c)
-\end{verbatim}
-Why have a \tr{y_entry} fragment at all?  The code generator should
-``know enough'' about \tr{y} not to need it.  For the first case
-above, with \tr{y} in ``head position,'' it should generate code just
-as for an \tr{StgRhsCon} (possibly because the STG simplification
-actually did the unfolding to make it so).  At the least, it should
-load up \tr{Node} and call \tr{Cons}'s entry code---not some special
-\tr{y_entry} code.
-
-\begin{pseudocode}
-	-- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name
-	-- FROM OUTSIDE.  NB: this CCodeBlock precedes the
-	-- CStaticClosure for the same reason (fewer forward refs) as
-	-- we did in CgClosure.
-
-	-- we either have ``in-line'' returning code (special case)
-	-- or we set Node and jump to the constructor's entry code
-
-    (if maybeToBool (maybeCharLikeTyCon con_tycon)
-     || maybeToBool (maybeIntLikeTyCon con_tycon)
-     then -- special case
-	getAbsC (-- OLD: No, we don't fiddle cost-centres on
-		 -- entry to data values any more (WDP 94/06)
-		 -- lexCostCentreC "ENTER_CC_D" [top_ccc]
-		 --  `thenC`
-		 cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-})
-     else -- boring case
-    	returnFC (
-	    mkAbstractCs [
-	      -- Node := this_closure
-	      CAssign (CReg node) (CLbl closure_label PtrKind),
-    	      -- InfoPtr := info table for this_closure
-    	      CAssign (CReg infoptr) (CLbl info_label DataPtrKind),
-	      -- Jump to std code for this constructor
-	      CJump (CLbl con_entry_label CodePtrKind)
-	    ])
-    )				    	   `thenFC` \ ret_absC ->
-
-    absC (CCodeBlock entry_label ret_absC) `thenC`
-\end{pseudocode}
-
-=========================== END OF OLD STUFF ==============================
-
+This blob used to be in cgTopRhsCon, but I don't see how we can jump
+direct to the named code for a constructor; any external entries will
+be via Node.  Generating all this extra code is a real waste for big
+static data structures.  So I've nuked it.  SLPJ Sept 94
 
 %************************************************************************
 %*									*
@@ -324,7 +252,7 @@ buildDynCon :: Id		-- Name of the thing to which this constr will
 	    -> DataCon		-- The data constructor
 	    -> [CAddrMode]	-- Its args
 	    -> Bool		-- True <=> all args (if any) are
-				-- of "zero size" (i.e., VoidKind);
+				-- of "zero size" (i.e., VoidRep);
 				-- The reason we don't just look at the
 				-- args is that we may be in a "knot", and
 				-- premature looking at the args will cause
@@ -333,32 +261,33 @@ buildDynCon :: Id		-- Name of the thing to which this constr will
 \end{code}
 
 First we deal with the case of zero-arity constructors.  Now, they
-will probably be unfolded, so we don't expect to see this case
-much, if at all, but it does no harm, and sets the scene for characters.
+will probably be unfolded, so we don't expect to see this case much,
+if at all, but it does no harm, and sets the scene for characters.
 
-In the case of zero-arity constructors, or, more accurately,
-those which have exclusively size-zero (VoidKind) args,
-we generate no code at all.
+In the case of zero-arity constructors, or, more accurately, those
+which have exclusively size-zero (VoidRep) args, we generate no code
+at all.
 
 \begin{code}
 buildDynCon binder cc con args all_zero_size_args@True
   = ASSERT(isDataCon con)
     returnFC (stableAmodeIdInfo binder
-				(CLbl (mkClosureLabel con) PtrKind) 
+				(CLbl (mkStaticClosureLabel con) PtrRep)
     				(mkConLFInfo con))
 \end{code}
 
 Now for @Char@-like closures.  We generate an assignment of the
 address of the closure to a temporary.  It would be possible simply to
-generate no code, and record the addressing mode in the environment, but
-we'd have to be careful if the argument wasn't a constant --- so for simplicity
-we just always asssign to a temporary.
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always asssign to a temporary.
 
-Last special case: @Int@-like closures.  We only special-case the situation
-in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@.
-NB: for @Char@-like closures we can work with any old argument, but
-for @Int@-like ones the argument has to be a literal.  Reason: @Char@ like
-closures have an argument type which is guaranteed in range.
+Last special case: @Int@-like closures.  We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal.  Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
 
 Because of this, we use can safely return an addressing mode.
 
@@ -374,11 +303,11 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False
   = ASSERT(isDataCon con)
     returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
   where
-    tycon = getDataConTyCon con
+    tycon = dataConTyCon con
     (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
 
-    in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
-    in_range_int_lit other_amode	    = False   
+    in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
+    in_range_int_lit other_amode	    = False
 \end{code}
 
 Now the general case.
@@ -390,7 +319,7 @@ buildDynCon binder cc con args all_zero_size_args@False
     returnFC (heapIdInfo binder hp_off (mkConLFInfo con))
   where
     (closure_info, amodes_w_offsets)
-      = layOutDynClosure binder getAmodeKind args (mkConLFInfo con)
+      = layOutDynClosure binder getAmodeRep args (mkConLFInfo con)
 
     use_cc	-- cost-centre to stick in the object
       = if currentOrSubsumedCosts cc
@@ -421,7 +350,7 @@ bindConArgs con args
       ReturnInRegs rs  -> bindArgsToRegs args rs
       ReturnInHeap     ->
 	  let
-	      (_, args_w_offsets) = layOutDynCon con getIdKind args
+	      (_, args_w_offsets) = layOutDynCon con idPrimRep args
 	  in
 	  mapCs bind_arg args_w_offsets
    where
@@ -439,17 +368,17 @@ bindConArgs con args
 Note: it's the responsibility of the @cgReturnDataCon@ caller to be
 sure the @amodes@ passed don't conflict with each other.
 \begin{code}
-cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> PlainStgLiveVars -> Code
+cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
 
 cgReturnDataCon con amodes all_zero_size_args live_vars
   = ASSERT(isDataCon con)
-    getEndOfBlockInfo		`thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+    getEndOfBlockInfo	`thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
 
     case sequel of
 
       CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
-	| not (getDataConTag con `is_elem` map fst alts)
-	->	
+	| not (dataConTag con `is_elem` map fst alts)
+	->
 		-- Special case!  We're returning a constructor to the default case
 		-- of an enclosing case.  For example:
 		--
@@ -457,7 +386,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 		--	  D x -> ...
 		--	  y   -> ...<returning here!>...
 		--
-		-- In this case, 
+		-- In this case,
 		--	if the default is a non-bind-default (ie does not use y),
 		--	then we should simply jump to the default join point;
 		--
@@ -466,21 +395,21 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 		--	**regardless** of the return convention of the constructor C.
 
 		case maybe_deflt_binder of
-		  Just binder -> 
+		  Just binder ->
 			buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args
 								`thenFC` \ idinfo ->
-			idInfoToAmode PtrKind idinfo		`thenFC` \ amode ->
+			idInfoToAmode PtrRep idinfo		`thenFC` \ amode ->
 			performReturn (move_to_reg amode node)  jump_to_join_point live_vars
 
 		  Nothing ->
 			performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars
 	where
 	  is_elem = isIn "cgReturnDataCon"
-	  jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind))
+	  jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
 		-- Ignore the sequel: we've already looked at it above
 
       other_sequel ->	-- The usual case
-	    case dataReturnConvAlg con of
+	    case (dataReturnConvAlg con) of
 
 	      ReturnInHeap	    ->
 			-- BUILD THE OBJECT IN THE HEAP
@@ -489,24 +418,24 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 			-- affects profiling (ToDo?)
 		  buildDynCon con useCurrentCostCentre con amodes all_zero_size_args
 							`thenFC` \ idinfo ->
-		  idInfoToAmode PtrKind idinfo		`thenFC` \ amode ->
-		
+		  idInfoToAmode PtrRep idinfo		`thenFC` \ amode ->
+
 			-- MAKE NODE POINT TO IT
 		  let reg_assts = move_to_reg amode node
-		      info_lbl  = mkInfoTableLabel con
+		      info_lbl  = mkConInfoTableLabel con
 		  in
 
 			-- RETURN
-		  profCtrC SLIT("RET_NEW_IN_HEAP") []		`thenC`
+		  profCtrC SLIT("RET_NEW_IN_HEAP") [mkIntCLit (length amodes)] `thenC`
 
 		  performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
 
 	      ReturnInRegs regs  ->
-	    	  let reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
+	    	  let
+		      reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
 		      info_lbl  = mkPhantomInfoTableLabel con
-	          in
---OLD:WDP:94/06	  evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
-		  profCtrC SLIT("RET_NEW_IN_REGS") []		   `thenC`
+		  in
+		  profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
 
 	    	  performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
   where