\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
- tagOf_PrimOp, -- ToDo: rm
- primOpType,
- primOpUniq, primOpOcc,
+ primOpType, primOpSig, primOpUsg,
+ mkPrimOpIdName, primOpRdrName,
commutableOp,
primOpOutOfLine, primOpNeedsWrapper, primOpStrictness,
- primOpOkForSpeculation, primOpIsCheap,
+ primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpHasSideEffects,
getPrimOpResultInfo, PrimOpResultInfo(..),
import TysWiredIn
import Demand ( Demand, wwLazy, wwPrim, wwStrict )
-import Var ( TyVar )
+import Var ( TyVar, Id )
import CallConv ( CallConv, pprCallConv )
import PprType ( pprParendType )
+import Name ( Name, mkWiredInIdName )
+import RdrName ( RdrName, mkRdrQual )
import OccName ( OccName, pprOccName, mkSrcVarOcc )
import TyCon ( TyCon, tyConArity )
-import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
+import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
mkTyConTy, mkTyConApp, typePrimRep,
- splitAlgTyConApp, Type, isUnboxedTupleType,
- splitAlgTyConApp_maybe
+ splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
+ UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
+import PrelMods ( pREL_GHC, pREL_GHC_Name )
import Outputable
-import Util ( assoc )
+import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
\end{code}
| IntegerToWord64Op | Word64ToIntegerOp
-- ?? gcd, etc?
- | FloatEncodeOp | FloatDecodeOp
- | DoubleEncodeOp | DoubleDecodeOp
+ | FloatDecodeOp
+ | DoubleDecodeOp
-- primitive ops for primitive arrays
| IndexOffForeignObjOp PrimRep
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
+ | UnsafeThawArrayOp | UnsafeThawByteArrayOp
| SizeofByteArrayOp | SizeofMutableByteArrayOp
-- Mutable variables
| CatchOp
| RaiseOp
+ -- foreign objects
| MakeForeignObjOp
| WriteForeignObjOp
+ -- weak pointers
| MkWeakOp
| DeRefWeakOp
| FinalizeWeakOp
+ -- stable names
| MakeStableNameOp
| EqStableNameOp
| StableNameToIntOp
+ -- stable pointers
| MakeStablePtrOp
| DeRefStablePtrOp
| EqStablePtrOp
-- concurrency
| ForkOp
| KillThreadOp
+ | YieldOp
+ | MyThreadIdOp
| DelayOp
| WaitReadOp
| WaitWriteOp
+ -- more parallel stuff
| ParGlobalOp -- named global par
| ParLocalOp -- named local par
| ParAtOp -- specifies destination of local par
| ParAtForNowOp -- specifies initial destination of global par
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
+
+ -- tag-related
+ | DataToTagOp
+ | TagToEnumOp
\end{code}
Used for the Ord instance
tagOf_PrimOp Int64ToIntegerOp = ILIT(121)
tagOf_PrimOp IntegerToWord64Op = ILIT(122)
tagOf_PrimOp Word64ToIntegerOp = ILIT(123)
-tagOf_PrimOp FloatEncodeOp = ILIT(124)
tagOf_PrimOp FloatDecodeOp = ILIT(125)
-tagOf_PrimOp DoubleEncodeOp = ILIT(126)
tagOf_PrimOp DoubleDecodeOp = ILIT(127)
tagOf_PrimOp NewArrayOp = ILIT(128)
tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(196)
tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(197)
-tagOf_PrimOp SizeofByteArrayOp = ILIT(198)
-tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(199)
-
-tagOf_PrimOp NewMVarOp = ILIT(200)
-tagOf_PrimOp TakeMVarOp = ILIT(201)
-tagOf_PrimOp PutMVarOp = ILIT(202)
-tagOf_PrimOp SameMVarOp = ILIT(203)
-tagOf_PrimOp IsEmptyMVarOp = ILIT(204)
-tagOf_PrimOp MakeForeignObjOp = ILIT(205)
-tagOf_PrimOp WriteForeignObjOp = ILIT(206)
-tagOf_PrimOp MkWeakOp = ILIT(207)
-tagOf_PrimOp DeRefWeakOp = ILIT(208)
-tagOf_PrimOp FinalizeWeakOp = ILIT(209)
-tagOf_PrimOp MakeStableNameOp = ILIT(210)
-tagOf_PrimOp EqStableNameOp = ILIT(211)
-tagOf_PrimOp StableNameToIntOp = ILIT(212)
-tagOf_PrimOp MakeStablePtrOp = ILIT(213)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(214)
-tagOf_PrimOp EqStablePtrOp = ILIT(215)
-tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(216)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(217)
-tagOf_PrimOp SeqOp = ILIT(218)
-tagOf_PrimOp ParOp = ILIT(219)
-tagOf_PrimOp ForkOp = ILIT(220)
-tagOf_PrimOp KillThreadOp = ILIT(221)
-tagOf_PrimOp DelayOp = ILIT(222)
-tagOf_PrimOp WaitReadOp = ILIT(223)
-tagOf_PrimOp WaitWriteOp = ILIT(224)
-tagOf_PrimOp ParGlobalOp = ILIT(225)
-tagOf_PrimOp ParLocalOp = ILIT(226)
-tagOf_PrimOp ParAtOp = ILIT(227)
-tagOf_PrimOp ParAtAbsOp = ILIT(228)
-tagOf_PrimOp ParAtRelOp = ILIT(229)
-tagOf_PrimOp ParAtForNowOp = ILIT(230)
-tagOf_PrimOp CopyableOp = ILIT(231)
-tagOf_PrimOp NoFollowOp = ILIT(232)
-tagOf_PrimOp NewMutVarOp = ILIT(233)
-tagOf_PrimOp ReadMutVarOp = ILIT(234)
-tagOf_PrimOp WriteMutVarOp = ILIT(235)
-tagOf_PrimOp SameMutVarOp = ILIT(236)
-tagOf_PrimOp CatchOp = ILIT(237)
-tagOf_PrimOp RaiseOp = ILIT(238)
+tagOf_PrimOp UnsafeThawArrayOp = ILIT(198)
+tagOf_PrimOp UnsafeThawByteArrayOp = ILIT(199)
+tagOf_PrimOp SizeofByteArrayOp = ILIT(200)
+tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(201)
+
+tagOf_PrimOp NewMVarOp = ILIT(202)
+tagOf_PrimOp TakeMVarOp = ILIT(203)
+tagOf_PrimOp PutMVarOp = ILIT(204)
+tagOf_PrimOp SameMVarOp = ILIT(205)
+tagOf_PrimOp IsEmptyMVarOp = ILIT(206)
+tagOf_PrimOp MakeForeignObjOp = ILIT(207)
+tagOf_PrimOp WriteForeignObjOp = ILIT(208)
+tagOf_PrimOp MkWeakOp = ILIT(209)
+tagOf_PrimOp DeRefWeakOp = ILIT(210)
+tagOf_PrimOp FinalizeWeakOp = ILIT(211)
+tagOf_PrimOp MakeStableNameOp = ILIT(212)
+tagOf_PrimOp EqStableNameOp = ILIT(213)
+tagOf_PrimOp StableNameToIntOp = ILIT(214)
+tagOf_PrimOp MakeStablePtrOp = ILIT(215)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(216)
+tagOf_PrimOp EqStablePtrOp = ILIT(217)
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(218)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(219)
+tagOf_PrimOp SeqOp = ILIT(220)
+tagOf_PrimOp ParOp = ILIT(221)
+tagOf_PrimOp ForkOp = ILIT(222)
+tagOf_PrimOp KillThreadOp = ILIT(223)
+tagOf_PrimOp YieldOp = ILIT(224)
+tagOf_PrimOp MyThreadIdOp = ILIT(225)
+tagOf_PrimOp DelayOp = ILIT(226)
+tagOf_PrimOp WaitReadOp = ILIT(227)
+tagOf_PrimOp WaitWriteOp = ILIT(228)
+tagOf_PrimOp ParGlobalOp = ILIT(229)
+tagOf_PrimOp ParLocalOp = ILIT(230)
+tagOf_PrimOp ParAtOp = ILIT(231)
+tagOf_PrimOp ParAtAbsOp = ILIT(232)
+tagOf_PrimOp ParAtRelOp = ILIT(233)
+tagOf_PrimOp ParAtForNowOp = ILIT(234)
+tagOf_PrimOp CopyableOp = ILIT(235)
+tagOf_PrimOp NoFollowOp = ILIT(236)
+tagOf_PrimOp NewMutVarOp = ILIT(237)
+tagOf_PrimOp ReadMutVarOp = ILIT(238)
+tagOf_PrimOp WriteMutVarOp = ILIT(239)
+tagOf_PrimOp SameMutVarOp = ILIT(240)
+tagOf_PrimOp CatchOp = ILIT(241)
+tagOf_PrimOp RaiseOp = ILIT(242)
+tagOf_PrimOp DataToTagOp = ILIT(243)
+tagOf_PrimOp TagToEnumOp = ILIT(244)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
--panic# "tagOf_PrimOp: pattern-match"
Int64ToIntegerOp,
IntegerToWord64Op,
Word64ToIntegerOp,
- FloatEncodeOp,
FloatDecodeOp,
- DoubleEncodeOp,
DoubleDecodeOp,
NewArrayOp,
NewByteArrayOp CharRep,
WriteOffAddrOp Word64Rep,
UnsafeFreezeArrayOp,
UnsafeFreezeByteArrayOp,
+ UnsafeThawArrayOp,
+ UnsafeThawByteArrayOp,
SizeofByteArrayOp,
SizeofMutableByteArrayOp,
NewMutVarOp,
ParOp,
ForkOp,
KillThreadOp,
+ YieldOp,
+ MyThreadIdOp,
DelayOp,
WaitReadOp,
- WaitWriteOp
+ WaitWriteOp,
+ DataToTagOp,
+ TagToEnumOp
]
\end{code}
-- the list of demands may be infinite!
-- Use only the ones you ned.
-primOpStrictness SeqOp = ([wwLazy], False)
+primOpStrictness SeqOp = ([wwStrict], False)
+ -- Seq is strict in its argument; see notes in ConFold.lhs
+
primOpStrictness ParOp = ([wwLazy], False)
+ -- But Par is lazy, to avoid that the sparked thing
+ -- gets evaluted strictly, which it should *not* be
+
primOpStrictness ForkOp = ([wwLazy, wwPrim], False)
primOpStrictness NewArrayOp = ([wwPrim, wwLazy, wwPrim], False)
primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False)
primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False)
+primOpStrictness DataToTagOp = ([wwLazy], False)
+
-- The rest all have primitive-typed arguments
primOpStrictness other = (repeat wwPrim, False)
\end{code}
%* *
%************************************************************************
-@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's
-similar).
+@decodeFloat#@ is given w/ Integer-stuff (it's similar).
\begin{code}
primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy
%* *
%************************************************************************
-@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's
-similar).
+@decodeDouble#@ is given w/ Integer-stuff (it's similar).
\begin{code}
primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy
= mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
\end{code}
-Encoding and decoding of floating-point numbers is sorta
-Integer-related.
+Decoding of floating-point numbers is sorta Integer-related. Encoding
+is done with plain ccalls now (see PrelNumExtra.lhs).
\begin{code}
-primOpInfo FloatEncodeOp
- = mkGenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy
-
-primOpInfo DoubleEncodeOp
- = mkGenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy
-
primOpInfo FloatDecodeOp
= mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
%* *
%************************************************************************
+\begin{verbatim}
+newArray# :: Int# -> a -> State# s -> (# State# s, MutArr# s a #)
+newFooArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #)
+\end{verbatim}
+
\begin{code}
primOpInfo NewArrayOp
= let {
---------------------------------------------------------------------------
+{-
+sameMutableArray# :: MutArr# s a -> MutArr# s a -> Bool
+sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool
+-}
+
primOpInfo SameMutableArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
---------------------------------------------------------------------------
-- Primitive arrays of Haskell pointers:
+{-
+readArray# :: MutArr# s a -> Int# -> State# s -> (# State# s, a #)
+writeArray# :: MutArr# s a -> Int# -> a -> State# s -> State# s
+indexArray# :: Array# a -> Int# -> (# a #)
+-}
+
primOpInfo ReadArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
primOpInfo IndexArrayOp
= let { elt = alphaTy; elt_tv = alphaTyVar } in
mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
- (unboxedPair [realWorldStatePrimTy, elt])
+ (mkUnboxedTupleTy 1 [elt])
---------------------------------------------------------------------------
-- Primitive arrays full of unboxed bytes:
(mkStatePrimTy s)
---------------------------------------------------------------------------
+{-
+unsafeFreezeArray# :: MutArr# s a -> State# s -> (# State# s, Array# a #)
+unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (# State# s, ByteArray# #)
+unsafeThawArray# :: Array# a -> State# s -> (# State# s, MutArr# s a #)
+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutByteArr# s #)
+-}
+
primOpInfo UnsafeFreezeArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
[mkMutableByteArrayPrimTy s, state]
(unboxedPair [state, byteArrayPrimTy])
+primOpInfo UnsafeThawArrayOp
+ = let {
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
+ state = mkStatePrimTy s
+ } in
+ mkGenPrimOp SLIT("unsafeThawArray#") [s_tv, elt_tv]
+ [mkArrayPrimTy elt, state]
+ (unboxedPair [state, mkMutableArrayPrimTy s elt])
+
+primOpInfo UnsafeThawByteArrayOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar;
+ state = mkStatePrimTy s
+ } in
+ mkGenPrimOp SLIT("unsafeThawByteArray#") [s_tv]
+ [byteArrayPrimTy, state]
+ (unboxedPair [state, mkMutableByteArrayPrimTy s])
+
---------------------------------------------------------------------------
primOpInfo SizeofByteArrayOp
= mkGenPrimOp
%* *
%************************************************************************
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch :: a -> (b -> a) -> a
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch# :: a -> (b -> a) -> a
\begin{code}
primOpInfo CatchOp
[alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
--- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
+-- killThread# :: ThreadId# -> exception -> State# RealWorld -> State# RealWorld
primOpInfo KillThreadOp
- = mkGenPrimOp SLIT("killThread#") []
- [threadIdPrimTy, realWorldStatePrimTy]
+ = mkGenPrimOp SLIT("killThread#") [alphaTyVar]
+ [threadIdPrimTy, alphaTy, realWorldStatePrimTy]
realWorldStatePrimTy
+
+-- yield# :: State# RealWorld -> State# RealWorld
+primOpInfo YieldOp
+ = mkGenPrimOp SLIT("yield#") []
+ [realWorldStatePrimTy]
+ realWorldStatePrimTy
+
+-- myThreadId# :: State# RealWorld -> (# State# RealWorld, ThreadId# #)
+primOpInfo MyThreadIdOp
+ = mkGenPrimOp SLIT("myThreadId#") []
+ [realWorldStatePrimTy]
+ (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
\end{code}
************************************************************************
routines.
\begin{verbatim}
-makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, a #)
+makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)
freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld
deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#
-- 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#
+-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine
+-- `the processor containing the expression v'; it is not evaluated
-primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParGlobalOp -- parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParLocalOp -- parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+primOpInfo ParAtOp -- parAt# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParAtAbsOp -- parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParAtRelOp -- parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+primOpInfo ParAtForNowOp -- parAtForNow# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-primOpInfo CopyableOp -- copyable# :: a -> a
+primOpInfo CopyableOp -- copyable# :: a -> Int#
= mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
-primOpInfo NoFollowOp -- noFollow# :: a -> a
+primOpInfo NoFollowOp -- noFollow# :: a -> Int#
= mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
where
(result_tycon, tys_applied, _) = splitAlgTyConApp result_ty
-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[PrimOp-tag]{PrimOpInfo for @dataToTag#@ and @tagToEnum#@}
+%* *
+%************************************************************************
+
+These primops are pretty wierd.
+
+ dataToTag# :: a -> Int (arg must be an evaluated data type)
+ tagToEnum# :: Int -> a (result type must be an enumerated type)
+
+The constraints aren't currently checked by the front end, but the
+code generator will fall over if they aren't satisfied.
+
+\begin{code}
+primOpInfo DataToTagOp
+ = mkGenPrimOp SLIT("dataToTag#") [alphaTyVar] [alphaTy] intPrimTy
+
+primOpInfo TagToEnumOp
+ = mkGenPrimOp SLIT("tagToEnum#") [alphaTyVar] [intPrimTy] alphaTy
+
#ifdef DEBUG
primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
#endif
\end{code}
+%************************************************************************
+%* *
+\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line}
+%* *
+%************************************************************************
+
Some PrimOps need to be called out-of-line because they either need to
perform a heap check or they block.
NewMVarOp -> True
ForkOp -> True
KillThreadOp -> True
+ YieldOp -> True
CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_
+ -- the next one doesn't perform any heap checks,
+ -- but it is of such an esoteric nature that
+ -- it is done out-of-line rather than require
+ -- the NCG to implement it.
+ UnsafeThawArrayOp -> True
_ -> False
\end{code}
primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)
\end{code}
+primOpIsDupable means that the use of the primop is small enough to
+duplicate into different case branches. See CoreUtils.exprIsDupable.
+
+\begin{code}
+primOpIsDupable (CCallOp _ _ might_gc _) = not might_gc
+ -- If the ccall can't GC then the call is pretty cheap, and
+ -- we're happy to duplicate
+primOpIsDupable op = not (primOpOutOfLine op)
+\end{code}
+
+
\begin{code}
primOpCanFail :: PrimOp -> Bool
-- Int.
primOpHasSideEffects ParOp = True
primOpHasSideEffects ForkOp = True
primOpHasSideEffects KillThreadOp = True
+primOpHasSideEffects YieldOp = True
primOpHasSideEffects SeqOp = True
primOpHasSideEffects MakeForeignObjOp = True
primOpNeedsWrapper FloatCoshOp = True
primOpNeedsWrapper FloatTanhOp = True
primOpNeedsWrapper FloatPowerOp = True
-primOpNeedsWrapper FloatEncodeOp = True
primOpNeedsWrapper DoubleExpOp = True
primOpNeedsWrapper DoubleLogOp = True
primOpNeedsWrapper DoubleCoshOp = True
primOpNeedsWrapper DoubleTanhOp = True
primOpNeedsWrapper DoublePowerOp = True
-primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper MakeStableNameOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
\end{code}
\begin{code}
-primOpOcc op
- = case (primOpInfo op) of
- Dyadic occ _ -> occ
- Monadic occ _ -> occ
- Compare occ _ -> occ
- GenPrimOp occ _ _ _ -> occ
-\end{code}
-
-\begin{code}
-primOpUniq :: PrimOp -> Unique
-primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
-
-primOpType :: PrimOp -> Type
+primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
Dyadic occ ty -> dyadic_fun_ty ty
GenPrimOp occ tyvars arg_tys res_ty ->
mkForAllTys tyvars (mkFunTys arg_tys res_ty)
+
+mkPrimOpIdName :: PrimOp -> Id -> 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 id
+ = mkWiredInIdName key pREL_GHC occ_name id
+ where
+ occ_name = primOpOcc op
+ key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp 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
+
+-- primOpSig is like primOpType but gives the result split apart:
+-- (type variables, argument types, result type)
+
+primOpSig :: PrimOp -> ([TyVar],[Type],Type)
+primOpSig op
+ = case (primOpInfo op) of
+ Monadic occ ty -> ([], [ty], ty )
+ Dyadic occ ty -> ([], [ty,ty], ty )
+ 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 op
+ = case op of
+
+ -- Refer to comment by `otherwise' clause; we need consider here
+ -- *only* primops that have arguments or results containing Haskell
+ -- pointers (things that are pointed). Unpointed values are
+ -- irrelevant to the usage analysis. The issue is whether pointed
+ -- values may be entered or duplicated by the primop.
+
+ -- Remember that primops are *never* partially applied.
+
+ NewArrayOp -> mangle [mkP, mkM, mkP ] mkM
+ SameMutableArrayOp -> mangle [mkP, mkP ] mkM
+ ReadArrayOp -> mangle [mkM, mkP, mkP ] mkM
+ WriteArrayOp -> mangle [mkM, mkP, mkM, mkP] mkR
+ IndexArrayOp -> mangle [mkM, mkP ] mkM
+ UnsafeFreezeArrayOp -> mangle [mkM, mkP ] mkM
+ UnsafeThawArrayOp -> mangle [mkM, mkP ] mkM
+
+ NewMutVarOp -> mangle [mkM, mkP ] mkM
+ ReadMutVarOp -> mangle [mkM, mkP ] mkM
+ WriteMutVarOp -> mangle [mkM, mkM, mkP ] mkR
+ SameMutVarOp -> mangle [mkP, mkP ] mkM
+
+ CatchOp -> -- [mkO, mkO . (inFun mkM mkO)] mkO
+ mangle [mkM, mkM . (inFun mkM mkM)] mkM
+ -- might use caught action multiply
+ RaiseOp -> mangle [mkM ] mkM
+
+ NewMVarOp -> mangle [mkP ] mkR
+ TakeMVarOp -> mangle [mkM, mkP ] mkM
+ PutMVarOp -> mangle [mkM, mkM, mkP ] mkR
+ SameMVarOp -> mangle [mkP, mkP ] mkM
+ IsEmptyMVarOp -> mangle [mkP, mkP ] mkM
+
+ ForkOp -> mangle [mkO, mkP ] mkR
+ KillThreadOp -> mangle [mkP, mkM, mkP ] mkR
+
+ MkWeakOp -> mangle [mkZ, mkM, mkM, mkP] mkM
+ DeRefWeakOp -> mangle [mkM, mkP ] mkM
+ FinalizeWeakOp -> mangle [mkM, mkP ] (mkR . (inUB [id,id,inFun mkR mkM]))
+
+ MakeStablePtrOp -> mangle [mkM, mkP ] mkM
+ DeRefStablePtrOp -> mangle [mkM, mkP ] mkM
+ EqStablePtrOp -> mangle [mkP, mkP ] mkR
+ MakeStableNameOp -> mangle [mkZ, mkP ] mkR
+ EqStableNameOp -> mangle [mkP, mkP ] mkR
+ StableNameToIntOp -> mangle [mkP ] mkR
+
+ ReallyUnsafePtrEqualityOp -> mangle [mkZ, mkZ ] mkR
+
+ SeqOp -> mangle [mkO ] mkR
+ ParOp -> mangle [mkO ] mkR
+ ParGlobalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParLocalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtAbsOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtRelOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtForNowOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
+ CopyableOp -> mangle [mkZ ] mkR
+ NoFollowOp -> mangle [mkZ ] mkR
+
+ CCallOp _ _ _ _ -> mangle [ ] mkM
+
+ -- 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.
+
+ otherwise -> nomangle
+
+ where 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
+
+ (tyvars, arg_tys, res_ty)
+ = primOpSig op
+
+ nomangle = (tyvars, map mkP arg_tys, mkR res_ty)
+
+ mangle fs g = (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)
+
+ inFun 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 fs ty = case splitTyConApp_maybe ty of
+ Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
+ mkUnboxedTupleTy (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 op
= case (primOpInfo op) of
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
- Compare _ ty -> ReturnsAlg boolTyCon
+ Compare _ ty -> ReturnsAlg boolTyCon
GenPrimOp _ _ _ ty ->
let rep = typePrimRep ty in
case rep of
other -> ReturnsPrim other
isCompareOp :: PrimOp -> Bool
-
isCompareOp op
= case primOpInfo op of
Compare _ _ -> True