\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}
-- 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
\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}
%************************************************************************
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.
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#
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}
primOpOkForSpeculation :: PrimOp -> Bool
-- See comments with CoreUtils.exprOkForSpeculation
primOpOkForSpeculation op
- = primOpIsCheap op && not (primOpCanFail op)
+ = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
\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
- -- 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
\begin{code}
primOpHasSideEffects :: PrimOp -> Bool
-primOpHasSideEffects (CCallOp _) = True
#include "primop-has-side-effects.hs-incl"
\end{code}
\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
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
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}
-- 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
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
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}
projects / ghc-hetmet.git / blobdiff