primOpOkForSpeculation, primOpIsCheap,
fragilePrimOp,
HeapRequirement(..), primOpHeapReq,
+ StackRequirement(..), primOpStackRequired,
-- export for the Native Code Generator
primOpInfo, -- needed for primOpNameInfo
pprPrimOp, showPrimOp
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PrimRep -- most of it
import TysPrim
import TysWiredIn
import CStrings ( identToC )
-import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import HeapOffs ( addOff, intOff, totHdrSize )
-import PprStyle ( codeStyle )
+import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
+import Outputable ( PprStyle, Outputable(..), codeStyle, ifaceStyle )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
-import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
- mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+import Type ( mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep,
+ getAppDataTyConExpandingDicts, SYN_IE(Type)
)
-import TyVar ( alphaTyVar, betaTyVar, GenTyVar{-instance Eq-} )
+import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
import Util ( panic#, assoc, panic{-ToDo:rm-} )
\end{code}
| IndexOffAddrOp PrimRep
-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
- -- Note that MallocPtrRep is not included -- the only way of
- -- creating a MallocPtr is with a ccall or casm.
+ -- Note that ForeignObjRep is not included -- the only way of
+ -- creating a ForeignObj is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
| TakeMVarOp | PutMVarOp
| ReadIVarOp | WriteIVarOp
+ | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
+ | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200]
| MakeStablePtrOp | DeRefStablePtrOp
\end{code}
| ParOp
| ForkOp
- -- two for concurrency
+ -- three for concurrency
| DelayOp
- | WaitOp
+ | WaitReadOp
+ | WaitWriteOp
-#ifdef GRAN
| ParGlobalOp -- named global par
| ParLocalOp -- named local par
| ParAtOp -- specifies destination of local par
+ | ParAtAbsOp -- specifies destination of local par (abs processor)
+ | ParAtRelOp -- specifies destination of local par (rel processor)
| ParAtForNowOp -- specifies initial destination of global par
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
-#endif {-GRAN-}
\end{code}
Deriving Ix is what we really want! ToDo
tagOf_PrimOp PutMVarOp = ILIT(152)
tagOf_PrimOp ReadIVarOp = ILIT(153)
tagOf_PrimOp WriteIVarOp = ILIT(154)
-tagOf_PrimOp MakeStablePtrOp = ILIT(155)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(156)
-tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(157)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(158)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(159)
-tagOf_PrimOp SeqOp = ILIT(160)
-tagOf_PrimOp ParOp = ILIT(161)
-tagOf_PrimOp ForkOp = ILIT(162)
-tagOf_PrimOp DelayOp = ILIT(163)
-tagOf_PrimOp WaitOp = ILIT(164)
-
-#ifdef GRAN
-tagOf_PrimOp ParGlobalOp = ILIT(165)
-tagOf_PrimOp ParLocalOp = ILIT(166)
-tagOf_PrimOp ParAtOp = ILIT(167)
-tagOf_PrimOp ParAtForNowOp = ILIT(168)
-tagOf_PrimOp CopyableOp = ILIT(169)
-tagOf_PrimOp NoFollowOp = ILIT(170)
-#endif {-GRAN-}
+tagOf_PrimOp MakeForeignObjOp = ILIT(155)
+tagOf_PrimOp WriteForeignObjOp = ILIT(156)
+tagOf_PrimOp MakeStablePtrOp = ILIT(157)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(158)
+tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(159)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(160)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(161)
+tagOf_PrimOp SeqOp = ILIT(162)
+tagOf_PrimOp ParOp = ILIT(163)
+tagOf_PrimOp ForkOp = ILIT(164)
+tagOf_PrimOp DelayOp = ILIT(165)
+tagOf_PrimOp WaitReadOp = ILIT(166)
+tagOf_PrimOp WaitWriteOp = ILIT(167)
+
+tagOf_PrimOp ParGlobalOp = ILIT(168)
+tagOf_PrimOp ParLocalOp = ILIT(169)
+tagOf_PrimOp ParAtOp = ILIT(170)
+tagOf_PrimOp ParAtAbsOp = ILIT(171)
+tagOf_PrimOp ParAtRelOp = ILIT(172)
+tagOf_PrimOp ParAtForNowOp = ILIT(173)
+tagOf_PrimOp CopyableOp = ILIT(174)
+tagOf_PrimOp NoFollowOp = ILIT(175)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
PutMVarOp,
ReadIVarOp,
WriteIVarOp,
+ MakeForeignObjOp,
+ WriteForeignObjOp,
MakeStablePtrOp,
DeRefStablePtrOp,
ReallyUnsafePtrEqualityOp,
ErrorIOPrimOp,
-#ifdef GRAN
ParGlobalOp,
ParLocalOp,
-#endif {-GRAN-}
+ ParAtOp,
+ ParAtAbsOp,
+ ParAtRelOp,
+ ParAtForNowOp,
+ CopyableOp,
+ NoFollowOp,
SeqOp,
ParOp,
ForkOp,
DelayOp,
- WaitOp
+ WaitReadOp,
+ WaitWriteOp
]
\end{code}
primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy
-primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy
-primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy
-primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy
-primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy
-primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy
+primOpInfo IntGtOp = Compare SLIT(">#") intPrimTy
+primOpInfo IntGeOp = Compare SLIT(">=#") intPrimTy
+primOpInfo IntEqOp = Compare SLIT("==#") intPrimTy
+primOpInfo IntNeOp = Compare SLIT("/=#") intPrimTy
+primOpInfo IntLtOp = Compare SLIT("<#") intPrimTy
+primOpInfo IntLeOp = Compare SLIT("<=#") intPrimTy
primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
-primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
-primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
-primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy
-primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy
-primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
+primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy
+primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy
+primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy
+primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy
+primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy
+primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo IntAddOp = Dyadic SLIT("plusInt#") intPrimTy
-primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
-primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
+primOpInfo IntAddOp = Dyadic SLIT("+#") intPrimTy
+primOpInfo IntSubOp = Dyadic SLIT("-#") intPrimTy
+primOpInfo IntMulOp = Dyadic SLIT("*#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
+primOpInfo IntAbsOp = Monadic SLIT("absInt#") intPrimTy
\end{code}
%************************************************************************
similar).
\begin{code}
-primOpInfo DoubleAddOp = Dyadic SLIT("plusDouble#") doublePrimTy
-primOpInfo DoubleSubOp = Dyadic SLIT("minusDouble#") doublePrimTy
-primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy
-primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy
+primOpInfo DoubleAddOp = Dyadic SLIT("+##") doublePrimTy
+primOpInfo DoubleSubOp = Dyadic SLIT("-##") doublePrimTy
+primOpInfo DoubleMulOp = Dyadic SLIT("*##") doublePrimTy
+primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy
primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy
primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy
primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy
primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy
-primOpInfo DoublePowerOp= Dyadic SLIT("powerDouble#") doublePrimTy
+primOpInfo DoublePowerOp= Dyadic SLIT("**##") doublePrimTy
\end{code}
%************************************************************************
[intPrimTy, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
-primOpInfo WaitOp
+primOpInfo WaitReadOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- PrimResult SLIT("wait#") [s_tv]
+ PrimResult SLIT("waitRead#") [s_tv]
[intPrimTy, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
+primOpInfo WaitWriteOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ PrimResult SLIT("waitWrite#") [s_tv]
+ [intPrimTy, mkStatePrimTy s]
+ statePrimTyCon VoidRep [s]
\end{code}
+%************************************************************************
+%* *
+\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects}
+%* *
+%************************************************************************
+
+Not everything should/can be in the Haskell heap. As an example, in an
+image processing application written in Haskell, you really would like
+to avoid heaving huge images between different space or generations of
+a garbage collector. Instead use @ForeignObj@ (formerly known as @MallocPtr@),
+which refer to some externally allocated structure/value. Using @ForeignObj@,
+just a reference to an image is present in the heap, the image could then
+be stored outside the Haskell heap, i.e., as a malloc'ed structure or in
+a completely separate address space alltogether.
+
+When a @ForeignObj@ becomes garbage, a user-defined finalisation routine
+associated with the object is invoked (currently, each ForeignObj has a
+direct reference to its finaliser). -- SOF
+
+A @ForeignObj@ is created by the @makeForeignObj#@ primitive:
+
+\begin{pseudocode}
+makeForeignObj# :: Addr# -- foreign object
+ -> Addr# -- ptr to its finaliser routine
+ -> StateAndForeignObj# _RealWorld# ForeignObj#
+\end{pseudocode}
+
+
+\begin{code}
+primOpInfo MakeForeignObjOp
+ = AlgResult SLIT("makeForeignObj#") []
+ [addrPrimTy, addrPrimTy, realWorldStatePrimTy]
+ stateAndForeignObjPrimTyCon [realWorldTy]
+\end{code}
+
+[Experimental--SOF]
+In addition, another @ForeignObj@ primitive is provided for destructively modifying
+the external object wrapped up inside a @ForeignObj@. This primitive is used
+when a mixed programming interface of implicit and explicit de-allocation is used,
+e.g., if @ForeignObj@s are used to implement @Handle@s, then @Handle@s can be
+released either explicitly (through @hClose@) or implicitly (via a finaliser).
+When releasing/closing the @Handle@ explicitly, care must be taken to avoid having
+the finaliser for the embedded @ForeignObj@ attempt the same thing later.
+We deal with this situation, by allowing the programmer to destructively modify
+the data field of the @ForeignObj@ to hold a special value the finaliser recognises,
+and does not attempt to free (e.g., filling the data slot with \tr{NULL}).
+
+\begin{pseudocode}
+writeForeignObj# :: ForeignObj# -- foreign object
+ -> Addr# -- new data value
+ -> StateAndForeignObj# _RealWorld# ForeignObj#
+\end{pseudocode}
+
+\begin{code}
+primOpInfo WriteForeignObjOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ PrimResult SLIT("writeForeignObj#") [s_tv]
+ [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s]
+ statePrimTyCon VoidRep [s]
+\end{code}
%************************************************************************
%* *
\end{code}
\begin{code}
-#ifdef GRAN
+-- 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#
+
+primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = PrimResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
+
+primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = PrimResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
-primOpInfo ParGlobalOp -- parGlobal# :: Int -> a -> b -> b
- = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+ = PrimResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy]
-primOpInfo ParLocalOp -- parLocal# :: Int -> a -> b -> b
- = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = PrimResult SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
-primOpInfo ParAtOp -- parAt# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = PrimResult SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy]
-primOpInfo ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+ = PrimResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy]
primOpInfo CopyableOp -- copyable# :: a -> a
- = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+ = PrimResult SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy]
primOpInfo NoFollowOp -- noFollow# :: a -> a
- = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
-
-#endif {-GRAN-}
+ = PrimResult SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy]
\end{code}
%************************************************************************
\begin{code}
primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
= PrimResult SLIT("errorIO#") []
- [mkPrimIoTy unitTy]
+ [primio_ish_ty unitTy]
statePrimTyCon VoidRep [realWorldTy]
+ where
+ primio_ish_ty result
+ = mkFunTy (mkStateTy realWorldTy) (mkTupleTy 2 [result, mkStateTy realWorldTy])
\end{code}
%************************************************************************
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = _trace "PrimOp.getAppDataTyConExpandingDicts" $
- getAppDataTyConExpandingDicts result_ty
+ (result_tycon, tys_applied, _) = getAppDataTyConExpandingDicts result_ty
+
+#ifdef DEBUG
+primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
+#endif
\end{code}
%************************************************************************
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
--- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
--- or if it returns a MallocPtr.
+{-
+ ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
+ or if it returns a ForeignObj.
-primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
-primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty)
- = if returnsMallocPtr
- then VariableHeapRequired
- else NoHeapRequired
- where
- returnsMallocPtr
- = case (maybeAppDataTyConExpandingDicts return_ty) of
- Nothing -> False
- Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
+ Hmm..the allocation for makeForeignObj# is known (and fixed), so
+ why dod we need to be so indeterminate about it? --SOF
+-}
+primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
+primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired
+
+primOpHeapReq MakeForeignObjOp = VariableHeapRequired
+primOpHeapReq WriteForeignObjOp = NoHeapRequired
-- this occasionally has to expand the Stable Pointer table
primOpHeapReq MakeStablePtrOp = VariableHeapRequired
-- A SeqOp requires unknown space to evaluate its argument
primOpHeapReq SeqOp = VariableHeapRequired
-#ifdef GRAN
-
--- a ParGlobalOp creates a single 4-tuple in the heap. ToDo: verify this!
-primOpHeapReq ParGlobalOp = trace "primOpHeapReq:ParGlobalOp:verify!" (
- FixedHeapRequired
- (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
- )
+-- GranSim sparks are stgMalloced i.e. no heap required
+primOpHeapReq ParGlobalOp = NoHeapRequired
+primOpHeapReq ParLocalOp = NoHeapRequired
+primOpHeapReq ParAtOp = NoHeapRequired
+primOpHeapReq ParAtAbsOp = NoHeapRequired
+primOpHeapReq ParAtRelOp = NoHeapRequired
+primOpHeapReq ParAtForNowOp = NoHeapRequired
+-- CopyableOp and NoFolowOp don't require heap; don't rely on default
+primOpHeapReq CopyableOp = NoHeapRequired
+primOpHeapReq NoFollowOp = NoHeapRequired
--- a ParLocalOp creates a single 4-tuple in the heap. ToDo: verify this!
-primOpHeapReq ParLocalOp = trace "primOpHeapReq:ParLocalOp:verify!" (
- FixedHeapRequired
- (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
- )
+primOpHeapReq other_op = NoHeapRequired
+\end{code}
--- ToDo: parAt, parAtForNow, copyable, noFollow !! (HWL)
-#endif {-GRAN-}
+The amount of stack required by primops.
-primOpHeapReq other_op = NoHeapRequired
+\begin{code}
+data StackRequirement
+ = NoStackRequired
+ | FixedStackRequired Int {-AStack-} Int {-BStack-}
+ | VariableStackRequired
+
+primOpStackRequired SeqOp = FixedStackRequired 0 {-AStack-} 2 {-BStack-}
+primOpStackRequired _ = VariableStackRequired
+-- ToDo: be more specific for certain primops (currently only used for seq)
\end{code}
Primops which can trigger GC have to be called carefully.
TakeMVarOp -> True
ReadIVarOp -> True
DelayOp -> True
- WaitOp -> True
+ WaitReadOp -> True
+ WaitWriteOp -> True
_ ->
case primOpHeapReq op of
VariableHeapRequired -> True
primOpOkForSpeculation ForkOp = False -- Likewise
primOpOkForSpeculation SeqOp = False -- Likewise
-#ifdef GRAN
primOpOkForSpeculation ParGlobalOp = False -- Could be expensive!
primOpOkForSpeculation ParLocalOp = False -- Could be expensive!
-#endif {-GRAN-}
+primOpOkForSpeculation ParAtOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtAbsOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtRelOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtForNowOp = False -- Could be expensive!
+primOpOkForSpeculation CopyableOp = False -- only tags closure
+primOpOkForSpeculation NoFollowOp = False -- only tags closure
-- The default is "yes it's ok for speculation"
primOpOkForSpeculation other_op = True
fragilePrimOp ParOp = True
fragilePrimOp ForkOp = True
fragilePrimOp SeqOp = True
-fragilePrimOp MakeStablePtrOp = True
+fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp WriteForeignObjOp = True -- SOF
+fragilePrimOp MakeStablePtrOp = True
fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR
-#ifdef GRAN
fragilePrimOp ParGlobalOp = True
fragilePrimOp ParLocalOp = True
-fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True -- Possibly not. ASP
-fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True -- Possibly not. ASP
-#endif {-GRAN-}
+fragilePrimOp ParAtOp = True
+fragilePrimOp ParAtAbsOp = True
+fragilePrimOp ParAtRelOp = True
+fragilePrimOp ParAtForNowOp = True
+fragilePrimOp CopyableOp = True -- Possibly not. ASP
+fragilePrimOp NoFollowOp = True -- Possibly not. ASP
fragilePrimOp other = False
\end{code}
primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper DoubleDecodeOp = True
+primOpNeedsWrapper MakeForeignObjOp = True
+primOpNeedsWrapper WriteForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
primOpNeedsWrapper ReadIVarOp = True
primOpNeedsWrapper DelayOp = True
-primOpNeedsWrapper WaitOp = True
+primOpNeedsWrapper WaitReadOp = True
+primOpNeedsWrapper WaitWriteOp = True
primOpNeedsWrapper other_op = False
\end{code}
\begin{code}
primOp_str op
= case (primOpInfo op) of
- Dyadic str _ -> str
- Monadic str _ -> str
- Compare str _ -> str
- Coercing str _ _ -> str
+ Dyadic str _ -> str
+ Monadic str _ -> str
+ Compare str _ -> str
+ Coercing str _ _ -> str
PrimResult str _ _ _ _ _ -> str
- AlgResult str _ _ _ _ -> str
+ AlgResult str _ _ _ _ -> str
\end{code}
@primOpType@ duplicates some work of @primOpId@, but since we
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
Compare str ty -> compare_fun_ty ty
- Coercing str ty1 ty2 -> mkFunTys [ty1] ty2
+ Coercing str ty1 ty2 -> mkFunTy ty1 ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
Utils:
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
-monadic_fun_ty ty = mkFunTys [ty] ty
+monadic_fun_ty ty = mkFunTy ty ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
Output stuff:
\begin{code}
-pprPrimOp :: PprStyle -> PrimOp -> Pretty
+pprPrimOp :: PprStyle -> PrimOp -> Doc
showPrimOp :: PprStyle -> PrimOp -> String
-showPrimOp sty op
- = ppShow 1000{-random-} (pprPrimOp sty op)
+showPrimOp sty op = render (pprPrimOp sty op)
pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
= let
before
= if is_casm then
- if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
+ if may_gc then "_casm_GC_ ``" else "_casm_ ``"
else
- if may_gc then "(_ccall_GC_ " else "(_ccall_ "
+ if may_gc then "_ccall_GC_ " else "_ccall_ "
after
- = if is_casm then ppStr "''" else ppNil
+ = if is_casm then text "''" else empty
pp_tys
- = ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys),
- ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"]
-
+ = hsep (map (pprParendGenType sty) (res_ty:arg_tys))
in
- ppBesides [ppStr before, ppPStr fun, after, pp_tys]
+ hcat [text before, ptext fun, after, space, brackets pp_tys]
pprPrimOp sty other_op
- = let
- str = primOp_str other_op
- in
- if codeStyle sty
- then identToC str
- else ppPStr str
+ | codeStyle sty -- For C just print the primop itself
+ = identToC str
+
+ | ifaceStyle sty -- For interfaces Print it qualified with GHC.
+ = ptext SLIT("GHC.") <> ptext str
+
+ | otherwise -- Unqualified is good enough
+ = ptext str
+ where
+ str = primOp_str other_op
+
+
instance Outputable PrimOp where
ppr sty op = pprPrimOp sty op