X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=413bdf70f2362a5d2324dfb23fe7ecf0c99fe799;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=5dd0ccbb3f66a991d7f763f846b2031bcfbd46d2;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 5dd0ccb..413bdf7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -11,25 +11,25 @@ module PrimOp ( tagOf_PrimOp, -- ToDo: rm primOp_str, -- sigh primOpType, isCompareOp, + commutableOp, PrimOpResultInfo(..), getPrimOpResultInfo, ---MOVE: primOpCanTriggerGC, primOpNeedsWrapper, ---MOVE: primOpOkForSpeculation, primOpIsCheap, ---MOVE: fragilePrimOp, ---MOVE: HeapRequirement(..), primOpHeapReq, + primOpCanTriggerGC, primOpNeedsWrapper, + primOpOkForSpeculation, primOpIsCheap, + fragilePrimOp, + HeapRequirement(..), primOpHeapReq, + StackRequirement(..), primOpStackRequired, -- export for the Native Code Generator primOpInfo, -- needed for primOpNameInfo PrimOpInfo(..), pprPrimOp, showPrimOp - - -- and to make the interface self-sufficient.... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import PrimRep -- most of it import TysPrim @@ -37,19 +37,18 @@ import TysWiredIn import CStrings ( identToC ) import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) -import NameTypes ( mkPreludeCoreName, FullName, ShortName ) -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 ) -import TyVar ( alphaTyVar, betaTyVar ) +import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts, + mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep + ) +import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) import Util ( panic#, assoc, panic{-ToDo:rm-} ) - -glueTyArgs = panic "PrimOp:glueTyArgs" -pprParendType = panic "PrimOp:pprParendType" -primRepFromType = panic "PrimOp:primRepFromType" \end{code} %************************************************************************ @@ -146,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 @@ -155,6 +154,7 @@ data PrimOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp + | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) | MakeStablePtrOp | DeRefStablePtrOp \end{code} @@ -241,18 +241,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 @@ -411,25 +412,27 @@ 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 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" @@ -593,19 +596,25 @@ allThePrimOps 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} @@ -632,7 +641,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 @@ -736,8 +745,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} %************************************************************************ @@ -783,8 +792,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} %************************************************************************ @@ -794,8 +803,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} %************************************************************************ @@ -814,8 +823,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 @@ -848,11 +857,11 @@ primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") 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 @@ -1119,16 +1128,56 @@ 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-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} %************************************************************************ %* * @@ -1241,27 +1290,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 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} %************************************************************************ @@ -1273,8 +1328,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} %************************************************************************ @@ -1287,7 +1345,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, _) = 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} %************************************************************************ @@ -1305,7 +1368,6 @@ unfortunate few, some unknown amount of heap is required (these are the ops which can trigger GC). \begin{code} -{- MOVE: data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset @@ -1339,18 +1401,12 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (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 @@ -1377,25 +1433,31 @@ primOpHeapReq ForkOp = 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. @@ -1403,18 +1465,17 @@ In particular, their arguments are guaranteed to be in registers, and a liveness mask tells which regs are live. \begin{code} -{- MOVE: -primOpCanTriggerGC op = - case op of +primOpCanTriggerGC op + = case op of TakeMVarOp -> True ReadIVarOp -> True DelayOp -> True - WaitOp -> True + WaitReadOp -> True + WaitWriteOp -> True _ -> case primOpHeapReq op of VariableHeapRequired -> True _ -> False --} \end{code} Sometimes we may choose to execute a PrimOp even though it isn't @@ -1429,7 +1490,6 @@ There should be no worries about side effects; that's all taken care of by data dependencies. \begin{code} -{- MOVE: primOpOkForSpeculation :: PrimOp -> Bool -- Int. @@ -1463,55 +1523,56 @@ 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 --} \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. \begin{code} -{-MOVE: primOpIsCheap op = primOpOkForSpeculation op && not (primOpCanTriggerGC op) --} \end{code} And some primops have side-effects and so, for example, must not be duplicated. \begin{code} -{- MOVE: fragilePrimOp :: PrimOp -> Bool 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} Primitive operations that perform calls need wrappers to save any live variables that are stored in caller-saves registers \begin{code} -{- MOVE: primOpNeedsWrapper :: PrimOp -> Bool primOpNeedsWrapper (CCallOp _ _ _ _ _) = True @@ -1563,6 +1624,7 @@ primOpNeedsWrapper DoublePowerOp = True primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper DoubleDecodeOp = True +primOpNeedsWrapper MakeForeignObjOp = True primOpNeedsWrapper MakeStablePtrOp = True primOpNeedsWrapper DeRefStablePtrOp = True @@ -1571,21 +1633,21 @@ primOpNeedsWrapper PutMVarOp = 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 - 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 @@ -1598,13 +1660,13 @@ 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 (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)) AlgResult str tyvars arg_tys tycon res_tys -> - mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)) + mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)) \end{code} \begin{code} @@ -1619,10 +1681,10 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Dyadic _ ty -> ReturnsPrim (primRepFromType ty) - Monadic _ ty -> ReturnsPrim (primRepFromType ty) + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) Compare _ ty -> ReturnsAlg boolTyCon - Coerce _ _ ty -> ReturnsPrim (primRepFromType ty) + Coercing _ _ ty -> ReturnsPrim (typePrimRep ty) PrimResult _ _ _ _ kind _ -> ReturnsPrim kind AlgResult _ _ _ tycon _ -> ReturnsAlg tycon @@ -1634,10 +1696,37 @@ isCompareOp op _ -> False \end{code} +The commutable ops are those for which we will try to move constants +to the right hand side for strength reduction. + +\begin{code} +commutableOp :: PrimOp -> Bool + +commutableOp CharEqOp = True +commutableOp CharNeOp = True +commutableOp IntAddOp = True +commutableOp IntMulOp = True +commutableOp AndOp = True +commutableOp OrOp = True +commutableOp IntEqOp = True +commutableOp IntNeOp = True +commutableOp IntegerAddOp = True +commutableOp IntegerMulOp = True +commutableOp FloatAddOp = True +commutableOp FloatMulOp = True +commutableOp FloatEqOp = True +commutableOp FloatNeOp = True +commutableOp DoubleAddOp = True +commutableOp DoubleMulOp = True +commutableOp DoubleEqOp = True +commutableOp DoubleNeOp = True +commutableOp _ = False +\end{code} + 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} @@ -1662,8 +1751,8 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) pp_tys = ppBesides [ppStr " { [", - ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys), - ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"] + ppIntersperse pp'SP{-'-} (map (pprParendGenType sty) arg_tys), + ppRbrack, ppSP, pprParendGenType sty res_ty, ppStr " })"] in ppBesides [ppStr before, ppPStr fun, after, pp_tys] @@ -1672,9 +1761,7 @@ pprPrimOp sty other_op = 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