X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=7ba7dd392b453cc9064c4a5b7477f3b5b536910b;hb=2494407a750053daa61718fac371487d04818e57;hp=0ea3f0aecdd8a3cd7c2ee35ba46e9c55ed9c51f2;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 0ea3f0a..7ba7dd3 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -20,6 +20,7 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, fragilePrimOp, HeapRequirement(..), primOpHeapReq, + StackRequirement(..), primOpStackRequired, -- export for the Native Code Generator primOpInfo, -- needed for primOpNameInfo @@ -28,24 +29,24 @@ module PrimOp ( 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 PprStyle ( codeStyle, ifaceStyle ) 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} @@ -144,8 +145,8 @@ data PrimOp | 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 @@ -153,6 +154,8 @@ data PrimOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp + | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) + | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200] | MakeStablePtrOp | DeRefStablePtrOp \end{code} @@ -239,18 +242,19 @@ about using it this way?? ADR) | 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 @@ -409,25 +413,28 @@ tagOf_PrimOp TakeMVarOp = ILIT(151) 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" @@ -591,19 +598,26 @@ allThePrimOps 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} @@ -630,7 +644,7 @@ data PrimOpInfo Type | Compare FAST_STRING -- string :: T -> T -> Bool Type - | Coerce FAST_STRING -- string :: T1 -> T2 + | Coercing FAST_STRING -- string :: T1 -> T2 Type Type @@ -691,12 +705,12 @@ primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy 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 @@ -719,12 +733,12 @@ primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy 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} %************************************************************************ @@ -734,8 +748,8 @@ primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy %************************************************************************ \begin{code} -primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy -primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy +primOpInfo OrdOp = Coercing SLIT("ord#") charPrimTy intPrimTy +primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy \end{code} %************************************************************************ @@ -745,9 +759,9 @@ primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy %************************************************************************ \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 @@ -781,8 +795,8 @@ primOpInfo ISraOp primOpInfo ISrlOp = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep [] -primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy -primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy +primOpInfo Int2WordOp = Coercing SLIT("int2Word#") intPrimTy wordPrimTy +primOpInfo Word2IntOp = Coercing SLIT("word2Int#") wordPrimTy intPrimTy \end{code} %************************************************************************ @@ -792,8 +806,8 @@ primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy %************************************************************************ \begin{code} -primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy -primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy +primOpInfo Int2AddrOp = Coercing SLIT("int2Addr#") intPrimTy addrPrimTy +primOpInfo Addr2IntOp = Coercing SLIT("addr2Int#") addrPrimTy intPrimTy \end{code} %************************************************************************ @@ -812,8 +826,8 @@ primOpInfo FloatMulOp = Dyadic SLIT("timesFloat#") floatPrimTy primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy -primOpInfo Float2IntOp = Coerce SLIT("float2Int#") floatPrimTy intPrimTy -primOpInfo Int2FloatOp = Coerce SLIT("int2Float#") intPrimTy floatPrimTy +primOpInfo Float2IntOp = Coercing SLIT("float2Int#") floatPrimTy intPrimTy +primOpInfo Int2FloatOp = Coercing SLIT("int2Float#") intPrimTy floatPrimTy primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy @@ -840,17 +854,17 @@ primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy 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 = Coerce SLIT("double2Int#") doublePrimTy intPrimTy -primOpInfo Int2DoubleOp = Coerce SLIT("int2Double#") intPrimTy doublePrimTy +primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy +primOpInfo Int2DoubleOp = Coercing SLIT("int2Double#") intPrimTy doublePrimTy -primOpInfo Double2FloatOp = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy -primOpInfo Float2DoubleOp = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy +primOpInfo Double2FloatOp = Coercing SLIT("double2Float#") doublePrimTy floatPrimTy +primOpInfo Float2DoubleOp = Coercing SLIT("float2Double#") floatPrimTy doublePrimTy primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy @@ -864,7 +878,7 @@ primOpInfo DoubleAtanOp = Monadic SLIT("atanDouble#") doublePrimTy 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} %************************************************************************ @@ -1117,16 +1131,85 @@ primOpInfo DelayOp [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} %************************************************************************ %* * @@ -1239,27 +1322,33 @@ primOpInfo ForkOp -- fork# :: a -> Int# \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} %************************************************************************ @@ -1271,8 +1360,11 @@ primOpInfo NoFollowOp -- noFollow# :: a -> a \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} %************************************************************************ @@ -1285,7 +1377,12 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# 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} %************************************************************************ @@ -1335,19 +1432,18 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (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 (maybeAppDataTyCon 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 @@ -1374,24 +1470,31 @@ primOpHeapReq ForkOp = 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. @@ -1404,7 +1507,8 @@ primOpCanTriggerGC op TakeMVarOp -> True ReadIVarOp -> True DelayOp -> True - WaitOp -> True + WaitReadOp -> True + WaitWriteOp -> True _ -> case primOpHeapReq op of VariableHeapRequired -> True @@ -1456,10 +1560,14 @@ primOpOkForSpeculation ParOp = False -- Could be expensive! 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 @@ -1482,15 +1590,19 @@ fragilePrimOp :: PrimOp -> Bool 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} @@ -1550,6 +1662,8 @@ primOpNeedsWrapper DoublePowerOp = True primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper DoubleDecodeOp = True +primOpNeedsWrapper MakeForeignObjOp = True +primOpNeedsWrapper WriteForeignObjOp = True primOpNeedsWrapper MakeStablePtrOp = True primOpNeedsWrapper DeRefStablePtrOp = True @@ -1558,7 +1672,8 @@ primOpNeedsWrapper PutMVarOp = True primOpNeedsWrapper ReadIVarOp = True primOpNeedsWrapper DelayOp = True -primOpNeedsWrapper WaitOp = True +primOpNeedsWrapper WaitReadOp = True +primOpNeedsWrapper WaitWriteOp = True primOpNeedsWrapper other_op = False \end{code} @@ -1566,12 +1681,12 @@ primOpNeedsWrapper other_op = False \begin{code} primOp_str op = case (primOpInfo op) of - Dyadic str _ -> str - Monadic str _ -> str - Compare str _ -> str - Coerce 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 @@ -1584,7 +1699,7 @@ primOpType op Dyadic str ty -> dyadic_fun_ty ty Monadic str ty -> monadic_fun_ty ty Compare str ty -> compare_fun_ty ty - Coerce 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)) @@ -1608,7 +1723,7 @@ getPrimOpResultInfo op Dyadic _ ty -> ReturnsPrim (typePrimRep ty) Monadic _ ty -> ReturnsPrim (typePrimRep ty) Compare _ ty -> ReturnsAlg boolTyCon - Coerce _ _ ty -> ReturnsPrim (typePrimRep ty) + Coercing _ _ ty -> ReturnsPrim (typePrimRep ty) PrimResult _ _ _ _ kind _ -> ReturnsPrim kind AlgResult _ _ _ tycon _ -> ReturnsAlg tycon @@ -1650,7 +1765,7 @@ commutableOp _ = False 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} @@ -1666,28 +1781,31 @@ 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 pp_tys - = ppBesides [ppStr " { [", - ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys), - ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"] - + = ppCat (map (pprParendGenType sty) (res_ty:arg_tys)) in - ppBesides [ppStr before, ppPStr fun, after, pp_tys] + ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack] 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. + = ppPStr SLIT("GHC.") `ppBeside` ppPStr str + + | otherwise -- Unqualified is good enough + = ppPStr str + where + str = primOp_str other_op + + instance Outputable PrimOp where ppr sty op = pprPrimOp sty op