X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=a65035228096c09f8408f3a2c8fe8fa8a688547b;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=4b4f0cc1f2567e4d26d67f2f6b3301b7f8f50743;hpb=af93bb787305c0401eb658f149021e22d1ab98cc;p=ghc-hetmet.git

diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 4b4f0cc..a650352 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -6,35 +6,27 @@
 \begin{code}
 module PrimOp (
 	PrimOp(..), allThePrimOps,
-	primOpType, primOpSig, primOpArity,
-	mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc,
-
-	commutableOp,
+	primOpType, primOpSig,
+	primOpTag, maxPrimOpTag, primOpOcc,
 
 	primOpOutOfLine, primOpNeedsWrapper, 
 	primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
-	primOpHasSideEffects,
 
 	getPrimOpResultInfo,  PrimOpResultInfo(..)
     ) where
 
 #include "HsVersions.h"
 
-import PrimRep		-- most of it
 import TysPrim
 import TysWiredIn
 
 import NewDemand
 import Var		( TyVar )
-import Name		( Name, mkWiredInName )
-import RdrName		( RdrName, mkRdrOrig )
-import OccName		( OccName, pprOccName, mkVarOcc )
-import TyCon		( TyCon, isPrimTyCon, tyConPrimRep )
-import Type		( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon )
-import PprType          () -- get at Outputable Type instance.
-import Unique		( mkPrimOpIdUnique )
+import OccName		( OccName, pprOccName, mkVarOccFS )
+import TyCon		( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
+import Type		( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
+			  typePrimRep )
 import BasicTypes	( Arity, Boxity(..) )
-import PrelNames	( pREL_GHC, pREL_GHC_Name )
 import Outputable
 import FastTypes
 \end{code}
@@ -63,7 +55,6 @@ primOpTag op = iBox (tagOf_PrimOp op)
 -- supplies   
 -- tagOf_PrimOp :: PrimOp -> FastInt
 #include "primop-tag.hs-incl"
-tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
 
 
 instance Eq PrimOp where
@@ -86,6 +77,7 @@ instance Show PrimOp where
 \end{code}
 
 An @Enum@-derived list would be better; meanwhile... (ToDo)
+
 \begin{code}
 allThePrimOps :: [PrimOp]
 allThePrimOps =
@@ -121,10 +113,10 @@ data PrimOpInfo
 		[Type] 
 		Type 
 
-mkDyadic str  ty = Dyadic  (mkVarOcc str) ty
-mkMonadic str ty = Monadic (mkVarOcc str) ty
-mkCompare str ty = Compare (mkVarOcc str) ty
-mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOcc str) tvs tys ty
+mkDyadic str  ty = Dyadic  (mkVarOccFS str) ty
+mkMonadic str ty = Monadic (mkVarOccFS str) ty
+mkCompare str ty = Compare (mkVarOccFS str) ty
+mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty
 \end{code}
 
 %************************************************************************
@@ -328,13 +320,28 @@ primOpIsCheap
 @primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
 WARNING), we just borrow some other predicates for a
 what-should-be-good-enough test.  "Cheap" means willing to call it more
-than once.  Evaluation order is unaffected.
+than once, and/or push it inside a lambda.  The latter could change the
+behaviour of 'seq' for primops that can fail, so we don't treat them as cheap.
 
 \begin{code}
 primOpIsCheap :: PrimOp -> Bool
-primOpIsCheap op = False
-	-- March 2001: be less eager to inline PrimOps
-	-- Was: not (primOpHasSideEffects op || primOpOutOfLine op)
+primOpIsCheap op = primOpOkForSpeculation op
+-- In March 2001, we changed this to 
+--	primOpIsCheap op = False
+-- thereby making *no* primops seem cheap.  But this killed eta
+-- expansion on case (x ==# y) of True -> \s -> ... 
+-- which is bad.  In particular a loop like
+--	doLoop n = loop 0
+--     where
+--         loop i | i == n    = return ()
+--                | otherwise = bar i >> loop (i+1)
+-- allocated a closure every time round because it doesn't eta expand.
+-- 
+-- The problem that originally gave rise to the change was
+--	let x = a +# b *# c in x +# x
+-- were we don't want to inline x. But primopIsCheap doesn't control
+-- that (it's exprIsDupable that does) so the problem doesn't occur
+-- even if primOpIsCheap sometimes says 'True'.
 \end{code}
 
 primOpIsDupable
@@ -372,14 +379,6 @@ primOpNeedsWrapper :: PrimOp -> Bool
 \end{code}
 
 \begin{code}
-primOpArity :: PrimOp -> Arity
-primOpArity op 
-  = case (primOpInfo op) of
-      Monadic occ ty			  -> 1
-      Dyadic occ ty			  -> 2
-      Compare occ ty 			  -> 2
-      GenPrimOp occ tyvars arg_tys res_ty -> length arg_tys
-		
 primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead
 primOpType op
   = case (primOpInfo op) of
@@ -390,22 +389,12 @@ primOpType op
       GenPrimOp occ tyvars arg_tys res_ty -> 
 	mkForAllTys tyvars (mkFunTys arg_tys res_ty)
 
-mkPrimOpIdName :: PrimOp -> Name
-	-- Make the name for the PrimOp's Id
-	-- We have to pass in the Id itself because it's a WiredInId
-	-- and hence recursive
-mkPrimOpIdName op
-  = mkWiredInName pREL_GHC (primOpOcc op) (mkPrimOpIdUnique (primOpTag op))
-
-primOpRdrName :: PrimOp -> RdrName 
-primOpRdrName op = mkRdrOrig pREL_GHC_Name (primOpOcc op)
-
 primOpOcc :: PrimOp -> OccName
 primOpOcc op = case (primOpInfo op) of
-			      Dyadic    occ _	  -> occ
-			      Monadic   occ _	  -> occ
-			      Compare   occ _	  -> occ
-			      GenPrimOp occ _ _ _ -> occ
+		Dyadic    occ _	    -> occ
+		Monadic   occ _	    -> occ
+		Compare   occ _	    -> occ
+		GenPrimOp occ _ _ _ -> occ
 
 -- primOpSig is like primOpType but gives the result split apart:
 -- (type variables, argument types, result type)
@@ -467,14 +456,6 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy
 Output stuff:
 \begin{code}
 pprPrimOp  :: PrimOp -> SDoc
-pprPrimOp other_op
-  = getPprStyle $ \ sty ->
-    if ifaceStyle sty then	-- For interfaces Print it qualified with PrelGHC.
-	ptext SLIT("PrelGHC.") <> pprOccName occ
-    else
-	pprOccName occ
-  where
-    occ = primOpOcc other_op
+pprPrimOp other_op = pprOccName (primOpOcc other_op)
 \end{code}
 
-