X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=94d42a074cf143cb40fab86b2865dd3240bb575e;hb=387a411e5d6478249de6872c283f2df78ef83bf4;hp=afec1a2ef04ea4d8e0274402e0a0eb87eab9d7d9;hpb=6c0d7900ae25ddb14d50ac3d6e895c8a960997b2;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index afec1a2..94d42a0 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -6,8 +6,8 @@ \begin{code} module PrimOp ( PrimOp(..), allThePrimOps, - primOpType, primOpSig, primOpUsg, primOpArity, - mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc, + primOpType, primOpSig, primOpArity, + mkPrimOpIdName, primOpTag, primOpOcc, commutableOp, @@ -15,7 +15,12 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, - getPrimOpResultInfo, PrimOpResultInfo(..) + getPrimOpResultInfo, PrimOpResultInfo(..), + + eqCharName, eqIntName, neqIntName, + ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName, + eqFloatName, ltFloatName, eqDoubleName, ltDoubleName, + ltIntName, geIntName, leIntName, minusIntName, tagToEnumName ) where #include "HsVersions.h" @@ -24,21 +29,17 @@ import PrimRep -- most of it import TysPrim import TysWiredIn -import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) +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 Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon ) +import PprType () -- get at Outputable Type instance. import Unique ( mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) -import PrelNames ( pREL_GHC, pREL_GHC_Name ) +import PrelNames ( gHC_PRIM ) import Outputable -import Util ( zipWithEqual ) import FastTypes \end{code} @@ -139,7 +140,7 @@ mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOcc str) tvs tys ty Not all primops are strict! \begin{code} -primOpStrictness :: PrimOp -> Arity -> StrictnessInfo +primOpStrictness :: PrimOp -> Arity -> StrictSig -- See Demand.StrictnessInfo for discussion of what the results -- The arity should be the arity of the primop; that's why -- this function isn't exported. @@ -262,40 +263,6 @@ Invariants: stable name. -[Alastair Reid is to blame for this!] - -These days, (Glasgow) Haskell seems to have a bit of everything from -other languages: strict operations, mutable variables, sequencing, -pointers, etc. About the only thing left is LISP's ability to test -for pointer equality. So, let's add it in! - -\begin{verbatim} -reallyUnsafePtrEquality :: a -> a -> Int# -\end{verbatim} - -which tests any two closures (of the same type) to see if they're the -same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid -difficulties of trying to box up the result.) - -NB This is {\em really unsafe\/} because even something as trivial as -a garbage collection might change the answer by removing indirections. -Still, no-one's forcing you to use it. If you're worried about little -things like loss of referential transparency, you might like to wrap -it all up in a monad-like thing as John O'Donnell and John Hughes did -for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop -Proceedings?) - -I'm thinking of using it to speed up a critical equality test in some -graphics stuff in a context where the possibility of saying that -denotationally equal things aren't isn't a problem (as long as it -doesn't happen too often.) ADR - -To Will: Jim said this was already in, but I can't see it so I'm -adding it. Up to you whether you add it. (Note that this could have -been readily implemented using a @veryDangerousCCall@ before they were -removed...) - - -- 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# @@ -432,10 +399,7 @@ mkPrimOpIdName :: PrimOp -> Name -- 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) + = mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of @@ -448,7 +412,7 @@ primOpOcc op = case (primOpInfo op) of -- (type variables, argument types, result type) -- It also gives arity, strictness info -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictnessInfo) +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) primOpSig op = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) where @@ -460,49 +424,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} @@ -525,6 +446,8 @@ getPrimOpResultInfo op where tc = tyConAppTyCon ty -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple, though, which + -- gives rise to a ReturnAlg \end{code} The commutable ops are those for which we will try to move constants @@ -545,14 +468,38 @@ 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} +%************************************************************************ +%* * + 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}