X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=18024f7def199cb96561c49c857b1dc1c730790c;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=82e1f0d41129b00e8b772e4cf6128e8b674f48ce;hpb=69b29b57f29e775ffbe2108f8315aca3a690a1bc;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 82e1f0d..18024f7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -6,47 +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(..), - - pprPrimOp, - CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp, - isDynamicTarget, dynamicTarget, setCCallUnique + getPrimOpResultInfo, PrimOpResultInfo(..) ) where #include "HsVersions.h" -import PrimRep -- most of it import TysPrim import TysWiredIn -import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) +import NewDemand import Var ( TyVar ) -import CallConv ( CallConv, pprCallConv ) -import Name ( Name, mkWiredInName ) -import RdrName ( RdrName, mkRdrQual ) import OccName ( OccName, pprOccName, mkVarOcc ) -import TyCon ( TyCon, tyConArity ) -import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys, - mkTyConApp, typePrimRep, - splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe, - UsageAnn(..), mkUsgTy - ) -import Unique ( Unique, mkPrimOpIdUnique ) +import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) +import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, + typePrimRep ) import BasicTypes ( Arity, Boxity(..) ) -import CStrings ( CLabelString, pprCLabelString ) -import PrelNames ( pREL_GHC, pREL_GHC_Name ) import Outputable -import Util ( zipWithEqual ) import FastTypes \end{code} @@ -63,7 +44,6 @@ These are in \tr{state-interface.verb} order. -- supplies: -- data PrimOp = ... #include "primop-data-decl.hs-incl" - | CCallOp CCall -- and don't forget to add CCall \end{code} Used for the Ord instance @@ -98,11 +78,11 @@ instance Show PrimOp where \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) + \begin{code} allThePrimOps :: [PrimOp] allThePrimOps = #include "primop-list.hs-incl" --- Doesn't include CCall, which is really a family of primops \end{code} %************************************************************************ @@ -149,7 +129,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. @@ -272,40 +252,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# @@ -335,8 +281,9 @@ primOpInfo op = pprPanic "primOpInfo:" (ppr op) Some PrimOps need to be called out-of-line because they either need to perform a heap check or they block. + \begin{code} -primOpOutOfLine (CCallOp c_call) = ccallMayGC c_call +primOpOutOfLine :: PrimOp -> Bool #include "primop-out-of-line.hs-incl" \end{code} @@ -365,7 +312,7 @@ See also @primOpIsCheap@ (below). primOpOkForSpeculation :: PrimOp -> Bool -- See comments with CoreUtils.exprOkForSpeculation primOpOkForSpeculation op - = primOpIsCheap op && not (primOpCanFail op) + = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) \end{code} @@ -374,12 +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 - -- See comments with CoreUtils.exprOkForSpeculation -primOpIsCheap op = 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 @@ -405,7 +368,6 @@ duplicated. \begin{code} primOpHasSideEffects :: PrimOp -> Bool -primOpHasSideEffects (CCallOp _) = True #include "primop-has-side-effects.hs-incl" \end{code} @@ -414,19 +376,10 @@ any live variables that are stored in caller-saves registers. \begin{code} primOpNeedsWrapper :: PrimOp -> Bool -primOpNeedsWrapper (CCallOp _) = True #include "primop-needs-wrapper.hs-incl" \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 @@ -437,28 +390,18 @@ 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 = mkRdrQual 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) -- 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 @@ -470,52 +413,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) -primOpUsg p@(CCallOp _) = mangle p [] mkM -#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 = mkUsgTy UsOnce -- pointed argument used zero -mkO = mkUsgTy UsOnce -- pointed argument used once -mkM = mkUsgTy UsMany -- pointed argument used multiply -mkP = mkUsgTy UsOnce -- unpointed argument -mkR = mkUsgTy 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_maybe ty of - Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) - mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" - ($) fs tys) - Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty) \end{code} \begin{code} @@ -528,21 +425,18 @@ data PrimOpResultInfo -- be out of line, or the code generator won't work. getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo -getPrimOpResultInfo (CCallOp _) - = ReturnsAlg unboxedPairTyCon getPrimOpResultInfo op = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (typePrimRep ty) - Monadic _ ty -> ReturnsPrim (typePrimRep ty) - Compare _ ty -> ReturnsAlg boolTyCon - GenPrimOp _ _ _ ty -> - let rep = typePrimRep ty in - case rep of - PtrRep -> case splitAlgTyConApp_maybe ty of - Nothing -> pprPanic "getPrimOpResultInfo" - (ppr ty <+> ppr op) - Just (tc,_,_) -> ReturnsAlg tc - other -> ReturnsPrim other + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) + Compare _ ty -> ReturnsAlg boolTyCon + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) + | otherwise -> ReturnsAlg tc + 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 @@ -555,15 +449,6 @@ commutableOp :: PrimOp -> Bool Utils: \begin{code} -mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type) - -- CharRep --> ([], Char#) - -- StablePtrRep --> ([a], StablePtr# a) -mkPrimTyApp tvs kind - = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs)) - where - tycon = primRepTyCon kind - forall_tvs = take (tyConArity tycon) tvs - dyadic_fun_ty ty = mkFunTys [ty, ty] ty monadic_fun_ty ty = mkFunTy ty ty compare_fun_ty ty = mkFunTys [ty, ty] boolTy @@ -572,93 +457,6 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} pprPrimOp :: PrimOp -> SDoc - -pprPrimOp (CCallOp c_call) = pprCCallOp c_call -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 -\end{code} - - -%************************************************************************ -%* * -\subsubsection{CCalls} -%* * -%************************************************************************ - -A special ``trap-door'' to use in making calls direct to C functions: -\begin{code} -data CCall - = CCall CCallTarget - Bool -- True <=> really a "casm" - Bool -- True <=> might invoke Haskell GC - CallConv -- calling convention to use. - deriving( Eq ) - -data CCallTarget - = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. - | DynamicTarget Unique -- First argument (an Addr#) is the function pointer - -- (unique is used to generate a 'typedef' to cast - -- the function pointer if compiling the ccall# down to - -- .hc code - can't do this inline for tedious reasons.) - -instance Eq CCallTarget where - (StaticTarget l1) == (StaticTarget l2) = l1 == l2 - (DynamicTarget _) == (DynamicTarget _) = True - -- Ignore the arbitrary unique; this is important when comparing - -- a dynamic ccall read from an interface file A.hi with the - -- one constructed from A.hs, when deciding whether the interface - -- has changed - t1 == t2 = False - -ccallMayGC :: CCall -> Bool -ccallMayGC (CCall _ _ may_gc _) = may_gc - -ccallIsCasm :: CCall -> Bool -ccallIsCasm (CCall _ c_asm _ _) = c_asm - -isDynamicTarget (DynamicTarget _) = True -isDynamicTarget (StaticTarget _) = False - -dynamicTarget :: CCallTarget -dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set") - -- The unique is really only to do with code generation, so it - -- is only set in CoreToStg; before then it's just an error message - -setCCallUnique :: CCall -> Unique -> CCall -setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq - = CCall (DynamicTarget uniq) is_asm may_gc cconv -setCCallUnique ccall uniq = ccall +pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} -\begin{code} -pprCCallOp (CCall fun is_casm may_gc cconv) - = hcat [ ifPprDebug callconv - , text "__", ppr_dyn - , text before , ppr_fun , after] - where - callconv = text "{-" <> pprCallConv cconv <> text "-}" - - before - | is_casm && may_gc = "casm_GC ``" - | is_casm = "casm ``" - | may_gc = "ccall_GC " - | otherwise = "ccall " - - after - | is_casm = text "''" - | otherwise = empty - - ppr_dyn = case fun of - DynamicTarget _ -> text "dyn_" - _ -> empty - - ppr_fun = case fun of - DynamicTarget _ -> text "\"\"" - StaticTarget fn -> pprCLabelString fn -\end{code}