X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=18024f7def199cb96561c49c857b1dc1c730790c;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=94d42a074cf143cb40fab86b2865dd3240bb575e;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 94d42a0..18024f7 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -6,39 +6,27 @@
 \begin{code}
 module PrimOp (
 	PrimOp(..), allThePrimOps,
-	primOpType, primOpSig, primOpArity,
-	mkPrimOpIdName, primOpTag, primOpOcc,
-
-	commutableOp,
+	primOpType, primOpSig,
+	primOpTag, maxPrimOpTag, primOpOcc,
 
 	primOpOutOfLine, primOpNeedsWrapper, 
 	primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
-	primOpHasSideEffects,
-
-	getPrimOpResultInfo,  PrimOpResultInfo(..),
 
-	eqCharName, eqIntName, neqIntName,
-	ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName,
-	eqFloatName, ltFloatName, eqDoubleName, ltDoubleName, 
-	ltIntName, geIntName, leIntName, minusIntName, tagToEnumName	
+	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 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 TyCon		( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) )
+import Type		( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon,
+			  typePrimRep )
 import BasicTypes	( Arity, Boxity(..) )
-import PrelNames	( gHC_PRIM )
 import Outputable
 import FastTypes
 \end{code}
@@ -90,6 +78,7 @@ instance Show PrimOp where
 \end{code}
 
 An @Enum@-derived list would be better; meanwhile... (ToDo)
+
 \begin{code}
 allThePrimOps :: [PrimOp]
 allThePrimOps =
@@ -332,13 +321,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
@@ -376,14 +380,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
@@ -394,19 +390,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 gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag 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)
@@ -471,35 +460,3 @@ pprPrimOp  :: PrimOp -> SDoc
 pprPrimOp other_op = pprOccName (primOpOcc other_op)
 \end{code}
 
-
-%************************************************************************
-%*									*
-	Names for some primops (for ndpFlatten/FlattenMonad.lhs)
-%*									*
-%************************************************************************
-
-\begin{code}
-eqIntName	= mkPrimOpIdName IntEqOp
-ltIntName	= mkPrimOpIdName IntLtOp
-geIntName	= mkPrimOpIdName IntGeOp
-leIntName	= mkPrimOpIdName IntLeOp
-neqIntName	= mkPrimOpIdName IntNeOp
-minusIntName	= mkPrimOpIdName IntSubOp
-
-eqCharName	= mkPrimOpIdName CharEqOp
-ltCharName	= mkPrimOpIdName CharLtOp
-
-eqFloatName	= mkPrimOpIdName FloatEqOp
-ltFloatName	= mkPrimOpIdName FloatLtOp
-
-eqDoubleName	= mkPrimOpIdName DoubleEqOp
-ltDoubleName	= mkPrimOpIdName DoubleLtOp
-
-eqWordName	= mkPrimOpIdName WordEqOp
-ltWordName	= mkPrimOpIdName WordLtOp
-
-eqAddrName	= mkPrimOpIdName AddrEqOp
-ltAddrName	= mkPrimOpIdName AddrLtOp
-
-tagToEnumName	= mkPrimOpIdName TagToEnumOp
-\end{code}