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 CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import HeapOffs ( addOff, intOff, totHdrSize )
-import PprStyle ( codeStyle )
+import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
+import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
-import Type ( getAppDataTyCon, maybeAppDataTyCon,
- mkForAllTys, mkFunTys, applyTyCon, typePrimRep
+import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
+ mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep
)
-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)
| 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 MakeStablePtrOp = ILIT(156)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(157)
+tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(158)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(159)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(160)
+tagOf_PrimOp SeqOp = ILIT(161)
+tagOf_PrimOp ParOp = ILIT(162)
+tagOf_PrimOp ForkOp = ILIT(163)
+tagOf_PrimOp DelayOp = ILIT(164)
+tagOf_PrimOp WaitReadOp = ILIT(165)
+tagOf_PrimOp WaitWriteOp = ILIT(166)
+
+tagOf_PrimOp ParGlobalOp = ILIT(167)
+tagOf_PrimOp ParLocalOp = ILIT(168)
+tagOf_PrimOp ParAtOp = ILIT(169)
+tagOf_PrimOp ParAtAbsOp = ILIT(170)
+tagOf_PrimOp ParAtRelOp = ILIT(171)
+tagOf_PrimOp ParAtForNowOp = ILIT(172)
+tagOf_PrimOp CopyableOp = ILIT(173)
+tagOf_PrimOp NoFollowOp = ILIT(174)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
PutMVarOp,
ReadIVarOp,
WriteIVarOp,
+ MakeForeignObjOp,
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}
[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-makeForeignObj]{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
+
+The only function defined over @ForeignObj@s is:
+
+\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}
%************************************************************************
%* *
\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 ParGlobalOp -- parGlobal# :: Int -> a -> b -> b
- = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] 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 ParLocalOp -- parLocal# :: Int -> a -> b -> b
- = AlgResult SLIT("parLocal#") [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 ParAtOp -- parAt# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+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 ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAtForNow#") [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# -> 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 "getAppDataTyCon.PrimOp" $ getAppDataTyCon result_ty
+ (result_tycon, tys_applied, _) = --trace "PrimOp.getAppDataTyConExpandingDicts" $
+ getAppDataTyConExpandingDicts result_ty
+
+#ifdef DEBUG
+primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
+#endif
\end{code}
%************************************************************************
(intOff mIN_MP_INT_SIZE)))
-- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
--- or if it returns a MallocPtr.
+-- 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 (maybeAppDataTyCon return_ty) of
- Nothing -> False
- Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
+primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
+primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired
+
+primOpHeapReq MakeForeignObjOp = VariableHeapRequired
-- 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
+-- 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 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))
- )
-
--- 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 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 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}
= let
str = primOp_str other_op
in
- if codeStyle sty
- then identToC str
- else ppPStr str
+ (if codeStyle sty then identToC else ppPStr) str
instance Outputable PrimOp where
ppr sty op = pprPrimOp sty op
projects / ghc-hetmet.git / blobdiff