\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
- primOpType, primOpSig, primOpUsg, 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,
- splitFunTy_maybe, tyConAppTyCon, splitTyConApp,
- mkUTy, usOnce, usMany
- )
-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 Util ( zipWithEqual )
import FastTypes
\end{code}
-- supplies
-- tagOf_PrimOp :: PrimOp -> FastInt
#include "primop-tag.hs-incl"
-tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
instance Eq PrimOp where
\end{code}
An @Enum@-derived list would be better; meanwhile... (ToDo)
+
\begin{code}
allThePrimOps :: [PrimOp]
allThePrimOps =
[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}
%************************************************************************
@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
\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
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)
Compare occ ty -> ([], [ty,ty], boolTy)
GenPrimOp occ tyvars arg_tys res_ty
-> (tyvars, arg_tys, res_ty)
-
--- primOpUsg is like primOpSig but the types it yields are the
--- appropriate sigma (i.e., usage-annotated) types,
--- as required by the UsageSP inference.
-
-primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
-#include "primop-usage.hs-incl"
-
--- Things with no Haskell pointers inside: in actuality, usages are
--- irrelevant here (hence it doesn't matter that some of these
--- apparently permit duplication; since such arguments are never
--- ENTERed anyway, the usage annotation they get is entirely irrelevant
--- except insofar as it propagates to infect other values that *are*
--- pointed.
-
-
--- Helper bits & pieces for usage info.
-
-mkZ = mkUTy usOnce -- pointed argument used zero
-mkO = mkUTy usOnce -- pointed argument used once
-mkM = mkUTy usMany -- pointed argument used multiply
-mkP = mkUTy usOnce -- unpointed argument
-mkR = mkUTy usMany -- unpointed result
-
-nomangle op
- = case primOpSig op of
- (tyvars, arg_tys, res_ty, _, _)
- -> (tyvars, map mkP arg_tys, mkR res_ty)
-
-mangle op fs g
- = case primOpSig op of
- (tyvars, arg_tys, res_ty, _, _)
- -> (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)
-
-inFun op f g ty
- = case splitFunTy_maybe ty of
- Just (a,b) -> mkFunTy (f a) (g b)
- Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
-
-inUB op fs ty
- = case splitTyConApp ty of
- (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
- mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys)
\end{code}
\begin{code}
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}
-
projects / ghc-hetmet.git / blobdiff