X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=a65035228096c09f8408f3a2c8fe8fa8a688547b;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=5259fc1964e7170f4c40eada907e5425d17c6a07;hpb=973539a893ff512a3e9ac408c1583a080de0abf4;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 5259fc1..a650352 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -6,40 +6,28 @@ \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} @@ -67,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 @@ -90,6 +77,7 @@ instance Show PrimOp where \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) + \begin{code} allThePrimOps :: [PrimOp] allThePrimOps = @@ -125,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} %************************************************************************ @@ -332,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 @@ -376,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 @@ -394,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) @@ -427,49 +412,6 @@ primOpSig op 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} @@ -514,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} -