[project @ 2002-06-18 13:58:22 by simonpj]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgExpr.lhs

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index a47eb92..2894de2 100644 (file)
--- 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.42 2001/03/13 12:50:30 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.49 2002/06/18 13:58:23 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -35,19 +35,19 @@ import CgTailCall   ( cgTailCall, performReturn, performPrimReturn,
                          tailCallPrimOp, returnUnboxedTuple
                        )
 import ClosureInfo     ( mkClosureLFInfo, mkSelectorLFInfo,
-                         mkApLFInfo, layOutDynCon )
+                         mkApLFInfo, layOutDynConstr )
 import CostCentre      ( sccAbleCostCentre, isSccCountCostCentre )
 import Id              ( idPrimRep, idType, Id )
 import VarSet
 import PrimOp          ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
 import PrimRep         ( PrimRep(..), isFollowableRep )
-import TyCon           ( maybeTyConSingleCon,
-                         isUnboxedTupleTyCon, isEnumerationTyCon )
+import TyCon           ( isUnboxedTupleTyCon, isEnumerationTyCon )
 import Type            ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
 import Maybes          ( maybeToBool )
 import ListSetOps      ( assocMaybe )
 import Unique          ( mkBuiltinUnique )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..) )
+import Util             ( lengthIs )
 import Outputable
 \end{code}
 
@@ -114,13 +114,13 @@ get in a tail-call position, however, we need to actually perform the
 call, so we treat it as an inline primop.
 
 \begin{code}
-cgExpr (StgPrimApp op@(CCallOp ccall) args res_ty)
+cgExpr (StgOpApp op@(StgFCallOp _ _) args res_ty)
   = primRetUnboxedTuple op args res_ty
 
 -- tagToEnum# is special: we need to pull the constructor out of the table,
 -- and perform an appropriate return.
 
-cgExpr (StgPrimApp TagToEnumOp [arg] res_ty) 
+cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) 
   = ASSERT(isEnumerationTyCon tycon)
     getArgAmode arg `thenFC` \amode ->
        -- save the tag in a temporary in case amode overlaps
@@ -145,14 +145,14 @@ cgExpr (StgPrimApp TagToEnumOp [arg] res_ty)
        tycon = tyConAppTyCon res_ty
 
 
-cgExpr x@(StgPrimApp op args res_ty)
-  | primOpOutOfLine op = tailCallPrimOp op args
-  | otherwise
-  = ASSERT(op /= SeqOp) -- can't handle SeqOp
+cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
+  | primOpOutOfLine primop 
+  = tailCallPrimOp primop args
 
-    getArgAmodes args  `thenFC` \ arg_amodes ->
+  | otherwise
+  = getArgAmodes args  `thenFC` \ arg_amodes ->
 
-    case (getPrimOpResultInfo op) of
+    case (getPrimOpResultInfo primop) of
 
        ReturnsPrim kind ->
            let result_amode = CReg (dataReturnConvPrim kind) in
@@ -255,7 +255,7 @@ centre.
 cgExpr (StgSCC cc expr)
   = ASSERT(sccAbleCostCentre cc)
     costCentresC
-       SLIT("SET_CCC")
+       FSLIT("SET_CCC")
        [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
     `thenC`
     cgExpr expr
@@ -316,22 +316,27 @@ mkRhsClosure      bndr cc bi srt
                         [(con, params, use_mask,
                            (StgApp selectee [{-no args-}]))]
                         StgNoDefault))
-  |  the_fv == scrutinee                       -- Scrutinee is the only free variable
-  && maybeToBool maybe_offset                  -- Selectee is a component of the tuple
+  |  the_fv == scrutinee               -- Scrutinee is the only free variable
+  && maybeToBool maybe_offset          -- Selectee is a component of the tuple
   && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
-  = ASSERT(is_single_constructor)
+  = -- NOT TRUE: ASSERT(is_single_constructor)
+    -- The simplifier may have statically determined that the single alternative
+    -- is the only possible case and eliminated the others, even if there are
+    -- other constructors in the datatype.  It's still ok to make a selector
+    -- thunk in this case, because we *know* which constructor the scrutinee
+    -- will evaluate to.
     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
   where
     lf_info              = mkSelectorLFInfo (idType bndr) offset_into_int 
-                               (isUpdatable upd_flag)
-    (_, params_w_offsets) = layOutDynCon con idPrimRep params
+                                               (isUpdatable upd_flag)
+    (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params
+                               -- Just want the layout
     maybe_offset         = assocMaybe params_w_offsets selectee
     Just the_offset      = maybe_offset
     offset_into_int       = the_offset - fixedHdrSize
-    is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+    bogus_name           = panic "mkRhsClosure"
 \end{code}
 
-
 Ap thunks
 ~~~~~~~~~
 
@@ -355,7 +360,7 @@ mkRhsClosure        bndr cc bi srt
                []                      -- No args; a thunk
                body@(StgApp fun_id args)
 
-  | length args + 1 == arity
+  | args `lengthIs` (arity-1)
        && all isFollowableRep (map idPrimRep fvs) 
        && isUpdatable upd_flag
        && arity <= mAX_SPEC_AP_SIZE 
@@ -375,11 +380,9 @@ The default case
 ~~~~~~~~~~~~~~~~
 \begin{code}
 mkRhsClosure bndr cc bi srt fvs upd_flag args body
-  = getSRTLabel                `thenFC` \ srt_label ->
-    let lf_info = 
-         mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
-    in
-    cgRhsClosure bndr cc bi fvs args body lf_info
+  = cgRhsClosure bndr cc bi srt fvs args body lf_info
+  where
+    lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 \end{code}
 
 
@@ -446,7 +449,7 @@ Little helper for primitives that return unboxed tuples.
 
 
 \begin{code}
-primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
+primRetUnboxedTuple :: StgOp -> [StgArg] -> Type -> Code
 primRetUnboxedTuple op args res_ty
   = getArgAmodes args      `thenFC` \ arg_amodes ->
     {-