X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=1e62e9c326c009205f3f6d498ff76d133bfb6d8a;hp=6527a7e62b982f70c5763db26f9f3d0c1da7d767;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e

diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 6527a7e..1e62e9c 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -37,14 +37,14 @@ import TysWiredIn
 
 import CStrings		( identToC )
 import CgCompInfo   	( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import HeapOffs		( addOff, intOff, totHdrSize )
-import PprStyle		( codeStyle, PprStyle(..){-ToDo:rm-} )
+import HeapOffs		( addOff, intOff, totHdrSize, HeapOffset )
+import PprStyle		( codeStyle{-, PprStyle(..) ToDo:rm-} )
 import PprType		( pprParendGenType, GenTyVar{-instance Outputable-} )
 import Pretty
 import SMRep	    	( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
 import TyCon		( TyCon{-instances-} )
 import Type		( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
-			  mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+			  mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep
 			)
 import TyVar		( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
 import Unique		( Unique{-instance Eq-} )
@@ -1292,30 +1292,31 @@ primOpInfo ForkOp	-- fork# :: a -> Int#
 \begin{code}
 -- HWL: The first 4 Int# in all par... annotations denote:
 --   name, granularity info, size of result, degree of parallelism
+--      Same  structure as _seq_ i.e. returns Int#
 
 primOpInfo ParGlobalOp	-- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
-  = AlgResult SLIT("parGlobal#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
+  = PrimResult SLIT("parGlobal#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep []   -- liftTyCon [betaTy]
 
 primOpInfo ParLocalOp	-- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
-  = AlgResult SLIT("parLocal#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
+  = PrimResult SLIT("parLocal#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep []   -- liftTyCon [betaTy]
 
 primOpInfo ParAtOp	-- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
-  = AlgResult SLIT("parAt#")	[alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
+  = PrimResult SLIT("parAt#")	[alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep []   -- liftTyCon [gammaTy]
 
 primOpInfo ParAtAbsOp	-- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
-  = AlgResult SLIT("parAtAbs#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
+  = PrimResult SLIT("parAtAbs#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep []   -- liftTyCon [betaTy]
 
 primOpInfo ParAtRelOp	-- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
-  = AlgResult SLIT("parAtRel#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
+  = PrimResult SLIT("parAtRel#")	[alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep []   -- liftTyCon [betaTy]
 
 primOpInfo ParAtForNowOp	-- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
-  = AlgResult SLIT("parAtForNow#")	[alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
+  = PrimResult SLIT("parAtForNow#")	[alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep []   -- liftTyCon [gammaTy]
 
 primOpInfo CopyableOp	-- copyable# :: a -> a
-  = AlgResult SLIT("copyable#")	[alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+  = PrimResult SLIT("copyable#")	[alphaTyVar] [alphaTy] intPrimTyCon IntRep []   -- liftTyCon [alphaTy]
 
 primOpInfo NoFollowOp	-- noFollow# :: a -> a
-  = AlgResult SLIT("noFollow#")	[alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+  = PrimResult SLIT("noFollow#")	[alphaTyVar] [alphaTy] intPrimTyCon IntRep []   -- liftTyCon [alphaTy]
 \end{code}
 
 %************************************************************************
@@ -1327,8 +1328,11 @@ primOpInfo NoFollowOp	-- noFollow# :: a -> a
 \begin{code}
 primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
   = PrimResult SLIT("errorIO#") []
-	[mkPrimIoTy unitTy]
+	[primio_ish_ty unitTy]
 	statePrimTyCon VoidRep [realWorldTy]
+  where
+    primio_ish_ty result
+      = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
 \end{code}
 
 %************************************************************************
@@ -1341,7 +1345,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
 primOpInfo (CCallOp _ _ _ arg_tys result_ty)
   = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
   where
-    (result_tycon, tys_applied, _) = -- _trace "PrimOp.getAppDataTyConExpandingDicts" $
+    (result_tycon, tys_applied, _) = --trace "PrimOp.getAppDataTyConExpandingDicts" $
 				     getAppDataTyConExpandingDicts result_ty
 
 #ifdef DEBUG
@@ -1638,12 +1642,12 @@ primOpNeedsWrapper other_op 	    	= False
 \begin{code}
 primOp_str op
   = case (primOpInfo op) of
-      Dyadic str _	       -> str
-      Monadic str _	       -> str
-      Compare str _	       -> str
-      Coercing str _ _	       -> str
+      Dyadic     str _	       -> str
+      Monadic    str _	       -> str
+      Compare    str _	       -> str
+      Coercing   str _ _       -> str
       PrimResult str _ _ _ _ _ -> str
-      AlgResult str _ _ _ _    -> str
+      AlgResult  str _ _ _ _   -> str
 \end{code}
 
 @primOpType@ duplicates some work of @primOpId@, but since we
@@ -1656,7 +1660,7 @@ primOpType op
       Dyadic str ty ->	    dyadic_fun_ty ty
       Monadic str ty ->	    monadic_fun_ty ty
       Compare str ty ->	    compare_fun_ty ty
-      Coercing str ty1 ty2 -> mkFunTys [ty1] ty2
+      Coercing str ty1 ty2 -> mkFunTy ty1 ty2
 
       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
 	mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
@@ -1722,7 +1726,7 @@ commutableOp _		  = False
 Utils:
 \begin{code}
 dyadic_fun_ty  ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTys [ty] ty
+monadic_fun_ty ty = mkFunTy  ty ty
 compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 \end{code}
 
@@ -1757,9 +1761,7 @@ pprPrimOp sty other_op
   = let
 	str = primOp_str other_op
     in
-    if codeStyle sty
-    then identToC str
-    else ppPStr str
+    (if codeStyle sty then identToC else ppPStr) str
 
 instance Outputable PrimOp where
     ppr sty op = pprPrimOp sty op