X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=18024f7def199cb96561c49c857b1dc1c730790c;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=75635a896f66c58612b1b21fc507cf8a69f96d26;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 75635a8..18024f7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -6,41 +6,29 @@ \begin{code} module PrimOp ( PrimOp(..), allThePrimOps, - tagOf_PrimOp, -- ToDo: rm - primOpType, - primOpUniq, primOpStr, + primOpType, primOpSig, + primOpTag, maxPrimOpTag, primOpOcc, - commutableOp, + primOpOutOfLine, primOpNeedsWrapper, + primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, - primOpOutOfLine, primOpNeedsWrapper, - primOpOkForSpeculation, primOpIsCheap, - primOpHasSideEffects, - - getPrimOpResultInfo, PrimOpResultInfo(..), - - pprPrimOp + getPrimOpResultInfo, PrimOpResultInfo(..) ) where #include "HsVersions.h" -import PrimRep -- most of it import TysPrim import TysWiredIn -import CStrings ( identToC ) +import NewDemand import Var ( TyVar ) -import CallConv ( CallConv, pprCallConv ) -import PprType ( pprParendType ) -import TyCon ( TyCon ) -import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, - mkTyConApp, typePrimRep, - splitAlgTyConApp, Type, isUnboxedTupleType, - splitAlgTyConApp_maybe - ) -import Unique ( Unique, mkPrimOpIdUnique ) +import OccName ( OccName, pprOccName, mkVarOcc ) +import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) +import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, + typePrimRep ) +import BasicTypes ( Arity, Boxity(..) ) import Outputable -import Util ( assoc ) -import GlaExts ( Int(..), Int#, (==#) ) +import FastTypes \end{code} %************************************************************************ @@ -52,484 +40,32 @@ import GlaExts ( Int(..), Int#, (==#) ) These are in \tr{state-interface.verb} order. \begin{code} -data PrimOp - -- dig the FORTRAN/C influence on the names... - - -- comparisons: - - = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp - | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp - | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp - | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp - | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp - | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp - - -- Char#-related ops: - | OrdOp | ChrOp - - -- Int#-related ops: - -- IntAbsOp unused?? ADR - | IntAddOp | IntSubOp | IntMulOp | IntQuotOp - | IntRemOp | IntNegOp | IntAbsOp - | ISllOp | ISraOp | ISrlOp -- shift {left,right} {arithmetic,logical} - - -- Word#-related ops: - | WordQuotOp | WordRemOp - | AndOp | OrOp | NotOp | XorOp - | SllOp | SrlOp -- shift {left,right} {logical} - | Int2WordOp | Word2IntOp -- casts - - -- Addr#-related ops: - | Int2AddrOp | Addr2IntOp -- casts - - -- Float#-related ops: - | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp - | Float2IntOp | Int2FloatOp - - | FloatExpOp | FloatLogOp | FloatSqrtOp - | FloatSinOp | FloatCosOp | FloatTanOp - | FloatAsinOp | FloatAcosOp | FloatAtanOp - | FloatSinhOp | FloatCoshOp | FloatTanhOp - -- not all machines have these available conveniently: - -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp - | FloatPowerOp -- ** op - - -- Double#-related ops: - | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp - | Double2IntOp | Int2DoubleOp - | Double2FloatOp | Float2DoubleOp - - | DoubleExpOp | DoubleLogOp | DoubleSqrtOp - | DoubleSinOp | DoubleCosOp | DoubleTanOp - | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp - | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp - -- not all machines have these available conveniently: - -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp - | DoublePowerOp -- ** op - - -- Integer (and related...) ops: - -- slightly weird -- to match GMP package. - | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerGcdOp - | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp - - | IntegerCmpOp - - | Integer2IntOp | Integer2WordOp - | Int2IntegerOp | Word2IntegerOp - | Addr2IntegerOp - -- casting to/from Integer and 64-bit (un)signed quantities. - | IntegerToInt64Op | Int64ToIntegerOp - | IntegerToWord64Op | Word64ToIntegerOp - -- ?? gcd, etc? - - | FloatEncodeOp | FloatDecodeOp - | DoubleEncodeOp | DoubleDecodeOp - - -- primitive ops for primitive arrays - - | NewArrayOp - | NewByteArrayOp PrimRep - - | SameMutableArrayOp - | SameMutableByteArrayOp - - | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs - - | ReadByteArrayOp PrimRep - | WriteByteArrayOp PrimRep - | IndexByteArrayOp PrimRep - | IndexOffAddrOp PrimRep - | WriteOffAddrOp 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 ForeignObjRep is not included -- the only way of - -- creating a ForeignObj is with a ccall or casm. - | IndexOffForeignObjOp PrimRep - - | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp - | SizeofByteArrayOp | SizeofMutableByteArrayOp - - -- Mutable variables - | NewMutVarOp - | ReadMutVarOp - | WriteMutVarOp - | SameMutVarOp - - -- for MVars - | NewMVarOp - | TakeMVarOp - | PutMVarOp - | SameMVarOp - - -- exceptions - | CatchOp - | RaiseOp - - | MakeForeignObjOp - | WriteForeignObjOp - - | MkWeakOp - | DeRefWeakOp - - | MakeStablePtrOp - | DeRefStablePtrOp - | EqStablePtrOp -\end{code} - -A special ``trap-door'' to use in making calls direct to C functions: -\begin{code} - | CCallOp (Either - FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'. - Unique) -- Right u => first argument (an Addr#) is the function pointer - -- (unique is used to - - - Bool -- True <=> really a "casm" - Bool -- True <=> might invoke Haskell GC - CallConv -- calling convention to use. - -- (... to be continued ... ) -\end{code} - -The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@. -(See @primOpInfo@ for details.) - -Note: that first arg and part of the result should be the system state -token (which we carry around to fool over-zealous optimisers) but -which isn't actually passed. - -For example, we represent -\begin{pseudocode} -((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld) -\end{pseudocode} -by -\begin{pseudocode} -Case - ( Prim - (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False) - -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse - [] - [w#, sp# i#] - ) - (AlgAlts [ ( FloatPrimAndIoWorld, - [f#, w#], - Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#] - ) ] - NoDefault - ) -\end{pseudocode} - -Nota Bene: there are some people who find the empty list of types in -the @Prim@ somewhat puzzling and would represent the above by -\begin{pseudocode} -Case - ( Prim - (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False) - -- :: /\ alpha1, alpha2 alpha3, alpha4. - -- alpha1 -> alpha2 -> alpha3 -> alpha4 - [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld] - [w#, sp# i#] - ) - (AlgAlts [ ( FloatPrimAndIoWorld, - [f#, w#], - Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#] - ) ] - NoDefault - ) -\end{pseudocode} - -But, this is a completely different way of using @CCallOp@. The most -major changes required if we switch to this are in @primOpInfo@, and -the desugarer. The major difficulty is in moving the HeapRequirement -stuff somewhere appropriate. (The advantage is that we could simplify -@CCallOp@ and record just the number of arguments with corresponding -simplifications in reading pragma unfoldings, the simplifier, -instantiation (etc) of core expressions, ... . Maybe we should think -about using it this way?? ADR) - -\begin{code} - -- (... continued from above ... ) - - -- Operation to test two closure addresses for equality (yes really!) - -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT! - | ReallyUnsafePtrEqualityOp - - -- parallel stuff - | SeqOp - | ParOp - - -- concurrency - | ForkOp - | KillThreadOp - | DelayOp - | WaitReadOp - | WaitWriteOp - - | 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 +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" \end{code} Used for the Ord instance \begin{code} -tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT) -tagOf_PrimOp CharGeOp = ILIT( 2) -tagOf_PrimOp CharEqOp = ILIT( 3) -tagOf_PrimOp CharNeOp = ILIT( 4) -tagOf_PrimOp CharLtOp = ILIT( 5) -tagOf_PrimOp CharLeOp = ILIT( 6) -tagOf_PrimOp IntGtOp = ILIT( 7) -tagOf_PrimOp IntGeOp = ILIT( 8) -tagOf_PrimOp IntEqOp = ILIT( 9) -tagOf_PrimOp IntNeOp = ILIT( 10) -tagOf_PrimOp IntLtOp = ILIT( 11) -tagOf_PrimOp IntLeOp = ILIT( 12) -tagOf_PrimOp WordGtOp = ILIT( 13) -tagOf_PrimOp WordGeOp = ILIT( 14) -tagOf_PrimOp WordEqOp = ILIT( 15) -tagOf_PrimOp WordNeOp = ILIT( 16) -tagOf_PrimOp WordLtOp = ILIT( 17) -tagOf_PrimOp WordLeOp = ILIT( 18) -tagOf_PrimOp AddrGtOp = ILIT( 19) -tagOf_PrimOp AddrGeOp = ILIT( 20) -tagOf_PrimOp AddrEqOp = ILIT( 21) -tagOf_PrimOp AddrNeOp = ILIT( 22) -tagOf_PrimOp AddrLtOp = ILIT( 23) -tagOf_PrimOp AddrLeOp = ILIT( 24) -tagOf_PrimOp FloatGtOp = ILIT( 25) -tagOf_PrimOp FloatGeOp = ILIT( 26) -tagOf_PrimOp FloatEqOp = ILIT( 27) -tagOf_PrimOp FloatNeOp = ILIT( 28) -tagOf_PrimOp FloatLtOp = ILIT( 29) -tagOf_PrimOp FloatLeOp = ILIT( 30) -tagOf_PrimOp DoubleGtOp = ILIT( 31) -tagOf_PrimOp DoubleGeOp = ILIT( 32) -tagOf_PrimOp DoubleEqOp = ILIT( 33) -tagOf_PrimOp DoubleNeOp = ILIT( 34) -tagOf_PrimOp DoubleLtOp = ILIT( 35) -tagOf_PrimOp DoubleLeOp = ILIT( 36) -tagOf_PrimOp OrdOp = ILIT( 37) -tagOf_PrimOp ChrOp = ILIT( 38) -tagOf_PrimOp IntAddOp = ILIT( 39) -tagOf_PrimOp IntSubOp = ILIT( 40) -tagOf_PrimOp IntMulOp = ILIT( 41) -tagOf_PrimOp IntQuotOp = ILIT( 42) -tagOf_PrimOp IntRemOp = ILIT( 43) -tagOf_PrimOp IntNegOp = ILIT( 44) -tagOf_PrimOp IntAbsOp = ILIT( 45) -tagOf_PrimOp WordQuotOp = ILIT( 46) -tagOf_PrimOp WordRemOp = ILIT( 47) -tagOf_PrimOp AndOp = ILIT( 48) -tagOf_PrimOp OrOp = ILIT( 49) -tagOf_PrimOp NotOp = ILIT( 50) -tagOf_PrimOp XorOp = ILIT( 51) -tagOf_PrimOp SllOp = ILIT( 52) -tagOf_PrimOp SrlOp = ILIT( 53) -tagOf_PrimOp ISllOp = ILIT( 54) -tagOf_PrimOp ISraOp = ILIT( 55) -tagOf_PrimOp ISrlOp = ILIT( 56) -tagOf_PrimOp Int2WordOp = ILIT( 57) -tagOf_PrimOp Word2IntOp = ILIT( 58) -tagOf_PrimOp Int2AddrOp = ILIT( 59) -tagOf_PrimOp Addr2IntOp = ILIT( 60) - -tagOf_PrimOp FloatAddOp = ILIT( 61) -tagOf_PrimOp FloatSubOp = ILIT( 62) -tagOf_PrimOp FloatMulOp = ILIT( 63) -tagOf_PrimOp FloatDivOp = ILIT( 64) -tagOf_PrimOp FloatNegOp = ILIT( 65) -tagOf_PrimOp Float2IntOp = ILIT( 66) -tagOf_PrimOp Int2FloatOp = ILIT( 67) -tagOf_PrimOp FloatExpOp = ILIT( 68) -tagOf_PrimOp FloatLogOp = ILIT( 69) -tagOf_PrimOp FloatSqrtOp = ILIT( 70) -tagOf_PrimOp FloatSinOp = ILIT( 71) -tagOf_PrimOp FloatCosOp = ILIT( 72) -tagOf_PrimOp FloatTanOp = ILIT( 73) -tagOf_PrimOp FloatAsinOp = ILIT( 74) -tagOf_PrimOp FloatAcosOp = ILIT( 75) -tagOf_PrimOp FloatAtanOp = ILIT( 76) -tagOf_PrimOp FloatSinhOp = ILIT( 77) -tagOf_PrimOp FloatCoshOp = ILIT( 78) -tagOf_PrimOp FloatTanhOp = ILIT( 79) -tagOf_PrimOp FloatPowerOp = ILIT( 80) - -tagOf_PrimOp DoubleAddOp = ILIT( 81) -tagOf_PrimOp DoubleSubOp = ILIT( 82) -tagOf_PrimOp DoubleMulOp = ILIT( 83) -tagOf_PrimOp DoubleDivOp = ILIT( 84) -tagOf_PrimOp DoubleNegOp = ILIT( 85) -tagOf_PrimOp Double2IntOp = ILIT( 86) -tagOf_PrimOp Int2DoubleOp = ILIT( 87) -tagOf_PrimOp Double2FloatOp = ILIT( 88) -tagOf_PrimOp Float2DoubleOp = ILIT( 89) -tagOf_PrimOp DoubleExpOp = ILIT( 90) -tagOf_PrimOp DoubleLogOp = ILIT( 91) -tagOf_PrimOp DoubleSqrtOp = ILIT( 92) -tagOf_PrimOp DoubleSinOp = ILIT( 93) -tagOf_PrimOp DoubleCosOp = ILIT( 94) -tagOf_PrimOp DoubleTanOp = ILIT( 95) -tagOf_PrimOp DoubleAsinOp = ILIT( 96) -tagOf_PrimOp DoubleAcosOp = ILIT( 97) -tagOf_PrimOp DoubleAtanOp = ILIT( 98) -tagOf_PrimOp DoubleSinhOp = ILIT( 99) -tagOf_PrimOp DoubleCoshOp = ILIT(100) -tagOf_PrimOp DoubleTanhOp = ILIT(101) -tagOf_PrimOp DoublePowerOp = ILIT(102) - -tagOf_PrimOp IntegerAddOp = ILIT(103) -tagOf_PrimOp IntegerSubOp = ILIT(104) -tagOf_PrimOp IntegerMulOp = ILIT(105) -tagOf_PrimOp IntegerGcdOp = ILIT(106) -tagOf_PrimOp IntegerQuotRemOp = ILIT(107) -tagOf_PrimOp IntegerDivModOp = ILIT(108) -tagOf_PrimOp IntegerNegOp = ILIT(109) -tagOf_PrimOp IntegerCmpOp = ILIT(110) -tagOf_PrimOp Integer2IntOp = ILIT(111) -tagOf_PrimOp Integer2WordOp = ILIT(112) -tagOf_PrimOp Int2IntegerOp = ILIT(113) -tagOf_PrimOp Word2IntegerOp = ILIT(114) -tagOf_PrimOp Addr2IntegerOp = ILIT(115) -tagOf_PrimOp IntegerToInt64Op = ILIT(116) -tagOf_PrimOp Int64ToIntegerOp = ILIT(117) -tagOf_PrimOp IntegerToWord64Op = ILIT(118) -tagOf_PrimOp Word64ToIntegerOp = ILIT(119) - -tagOf_PrimOp FloatEncodeOp = ILIT(120) -tagOf_PrimOp FloatDecodeOp = ILIT(121) -tagOf_PrimOp DoubleEncodeOp = ILIT(122) -tagOf_PrimOp DoubleDecodeOp = ILIT(123) - -tagOf_PrimOp NewArrayOp = ILIT(124) -tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(125) -tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(126) -tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(127) -tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(128) -tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(129) -tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(130) -tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(131) -tagOf_PrimOp SameMutableArrayOp = ILIT(132) -tagOf_PrimOp SameMutableByteArrayOp = ILIT(133) -tagOf_PrimOp ReadArrayOp = ILIT(134) -tagOf_PrimOp WriteArrayOp = ILIT(135) -tagOf_PrimOp IndexArrayOp = ILIT(136) - -tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(137) -tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(138) -tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(139) -tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(140) -tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(141) -tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(142) -tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(143) -tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(144) -tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(145) - -tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(146) -tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(147) -tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(148) -tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(149) -tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(150) -tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(151) -tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(152) -tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(153) -tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(154) - -tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(155) -tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(156) -tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(157) -tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(158) -tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(159) -tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(160) -tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(161) -tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(162) -tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(163) - -tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(164) -tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(165) -tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(166) -tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(167) -tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(168) -tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(169) -tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(170) -tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(171) -tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(172) -tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(173) -tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(174) -tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(175) -tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(176) -tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(177) -tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(178) -tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(179) -tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(180) -tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(181) - -tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(182) -tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(183) -tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(184) -tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(185) -tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(186) -tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(187) -tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(188) -tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(189) -tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(190) -tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(191) - -tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(192) -tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(193) -tagOf_PrimOp SizeofByteArrayOp = ILIT(194) -tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(195) -tagOf_PrimOp NewMVarOp = ILIT(196) -tagOf_PrimOp TakeMVarOp = ILIT(197) -tagOf_PrimOp PutMVarOp = ILIT(198) -tagOf_PrimOp SameMVarOp = ILIT(199) -tagOf_PrimOp MakeForeignObjOp = ILIT(200) -tagOf_PrimOp WriteForeignObjOp = ILIT(201) -tagOf_PrimOp MkWeakOp = ILIT(202) -tagOf_PrimOp DeRefWeakOp = ILIT(203) -tagOf_PrimOp MakeStablePtrOp = ILIT(204) -tagOf_PrimOp DeRefStablePtrOp = ILIT(205) -tagOf_PrimOp EqStablePtrOp = ILIT(206) -tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(207) -tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(208) -tagOf_PrimOp SeqOp = ILIT(209) -tagOf_PrimOp ParOp = ILIT(210) -tagOf_PrimOp ForkOp = ILIT(211) -tagOf_PrimOp KillThreadOp = ILIT(212) -tagOf_PrimOp DelayOp = ILIT(213) -tagOf_PrimOp WaitReadOp = ILIT(214) -tagOf_PrimOp WaitWriteOp = ILIT(215) -tagOf_PrimOp ParGlobalOp = ILIT(216) -tagOf_PrimOp ParLocalOp = ILIT(217) -tagOf_PrimOp ParAtOp = ILIT(218) -tagOf_PrimOp ParAtAbsOp = ILIT(219) -tagOf_PrimOp ParAtRelOp = ILIT(220) -tagOf_PrimOp ParAtForNowOp = ILIT(221) -tagOf_PrimOp CopyableOp = ILIT(222) -tagOf_PrimOp NoFollowOp = ILIT(223) -tagOf_PrimOp NewMutVarOp = ILIT(224) -tagOf_PrimOp ReadMutVarOp = ILIT(225) -tagOf_PrimOp WriteMutVarOp = ILIT(226) -tagOf_PrimOp SameMutVarOp = ILIT(227) -tagOf_PrimOp CatchOp = ILIT(228) -tagOf_PrimOp RaiseOp = ILIT(229) +primOpTag :: PrimOp -> Int +primOpTag op = iBox (tagOf_PrimOp op) +-- supplies +-- tagOf_PrimOp :: PrimOp -> FastInt +#include "primop-tag.hs-incl" tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) ---panic# "tagOf_PrimOp: pattern-match" + instance Eq PrimOp where - op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2 + op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 instance Ord PrimOp where - op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2 - op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2 - op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2 - op1 > op2 = tagOf_PrimOp op1 _GT_ tagOf_PrimOp op2 + op1 < op2 = tagOf_PrimOp op1 <# tagOf_PrimOp op2 + op1 <= op2 = tagOf_PrimOp op1 <=# tagOf_PrimOp op2 + op1 >= op2 = tagOf_PrimOp op1 >=# tagOf_PrimOp op2 + op1 > op2 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 op1 `compare` op2 | op1 < op2 = LT | op1 == op2 = EQ | otherwise = GT @@ -542,237 +78,11 @@ instance Show PrimOp where \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) + \begin{code} -allThePrimOps - = [ CharGtOp, - CharGeOp, - CharEqOp, - CharNeOp, - CharLtOp, - CharLeOp, - IntGtOp, - IntGeOp, - IntEqOp, - IntNeOp, - IntLtOp, - IntLeOp, - WordGtOp, - WordGeOp, - WordEqOp, - WordNeOp, - WordLtOp, - WordLeOp, - AddrGtOp, - AddrGeOp, - AddrEqOp, - AddrNeOp, - AddrLtOp, - AddrLeOp, - FloatGtOp, - FloatGeOp, - FloatEqOp, - FloatNeOp, - FloatLtOp, - FloatLeOp, - DoubleGtOp, - DoubleGeOp, - DoubleEqOp, - DoubleNeOp, - DoubleLtOp, - DoubleLeOp, - OrdOp, - ChrOp, - IntAddOp, - IntSubOp, - IntMulOp, - IntQuotOp, - IntRemOp, - IntNegOp, - WordQuotOp, - WordRemOp, - AndOp, - OrOp, - NotOp, - XorOp, - SllOp, - SrlOp, - ISllOp, - ISraOp, - ISrlOp, - Int2WordOp, - Word2IntOp, - Int2AddrOp, - Addr2IntOp, - - FloatAddOp, - FloatSubOp, - FloatMulOp, - FloatDivOp, - FloatNegOp, - Float2IntOp, - Int2FloatOp, - FloatExpOp, - FloatLogOp, - FloatSqrtOp, - FloatSinOp, - FloatCosOp, - FloatTanOp, - FloatAsinOp, - FloatAcosOp, - FloatAtanOp, - FloatSinhOp, - FloatCoshOp, - FloatTanhOp, - FloatPowerOp, - DoubleAddOp, - DoubleSubOp, - DoubleMulOp, - DoubleDivOp, - DoubleNegOp, - Double2IntOp, - Int2DoubleOp, - Double2FloatOp, - Float2DoubleOp, - DoubleExpOp, - DoubleLogOp, - DoubleSqrtOp, - DoubleSinOp, - DoubleCosOp, - DoubleTanOp, - DoubleAsinOp, - DoubleAcosOp, - DoubleAtanOp, - DoubleSinhOp, - DoubleCoshOp, - DoubleTanhOp, - DoublePowerOp, - IntegerAddOp, - IntegerSubOp, - IntegerMulOp, - IntegerGcdOp, - IntegerQuotRemOp, - IntegerDivModOp, - IntegerNegOp, - IntegerCmpOp, - Integer2IntOp, - Integer2WordOp, - Int2IntegerOp, - Word2IntegerOp, - Addr2IntegerOp, - IntegerToInt64Op, - Int64ToIntegerOp, - IntegerToWord64Op, - Word64ToIntegerOp, - FloatEncodeOp, - FloatDecodeOp, - DoubleEncodeOp, - DoubleDecodeOp, - NewArrayOp, - NewByteArrayOp CharRep, - NewByteArrayOp IntRep, - NewByteArrayOp WordRep, - NewByteArrayOp AddrRep, - NewByteArrayOp FloatRep, - NewByteArrayOp DoubleRep, - NewByteArrayOp StablePtrRep, - SameMutableArrayOp, - SameMutableByteArrayOp, - ReadArrayOp, - WriteArrayOp, - IndexArrayOp, - ReadByteArrayOp CharRep, - ReadByteArrayOp IntRep, - ReadByteArrayOp WordRep, - ReadByteArrayOp AddrRep, - ReadByteArrayOp FloatRep, - ReadByteArrayOp DoubleRep, - ReadByteArrayOp StablePtrRep, - ReadByteArrayOp Int64Rep, - ReadByteArrayOp Word64Rep, - WriteByteArrayOp CharRep, - WriteByteArrayOp IntRep, - WriteByteArrayOp WordRep, - WriteByteArrayOp AddrRep, - WriteByteArrayOp FloatRep, - WriteByteArrayOp DoubleRep, - WriteByteArrayOp StablePtrRep, - WriteByteArrayOp Int64Rep, - WriteByteArrayOp Word64Rep, - IndexByteArrayOp CharRep, - IndexByteArrayOp IntRep, - IndexByteArrayOp WordRep, - IndexByteArrayOp AddrRep, - IndexByteArrayOp FloatRep, - IndexByteArrayOp DoubleRep, - IndexByteArrayOp StablePtrRep, - IndexByteArrayOp Int64Rep, - IndexByteArrayOp Word64Rep, - IndexOffForeignObjOp CharRep, - IndexOffForeignObjOp AddrRep, - IndexOffForeignObjOp IntRep, - IndexOffForeignObjOp WordRep, - IndexOffForeignObjOp FloatRep, - IndexOffForeignObjOp DoubleRep, - IndexOffForeignObjOp StablePtrRep, - IndexOffForeignObjOp Int64Rep, - IndexOffForeignObjOp Word64Rep, - IndexOffAddrOp CharRep, - IndexOffAddrOp IntRep, - IndexOffAddrOp WordRep, - IndexOffAddrOp AddrRep, - IndexOffAddrOp FloatRep, - IndexOffAddrOp DoubleRep, - IndexOffAddrOp StablePtrRep, - IndexOffAddrOp Int64Rep, - IndexOffAddrOp Word64Rep, - WriteOffAddrOp CharRep, - WriteOffAddrOp IntRep, - WriteOffAddrOp WordRep, - WriteOffAddrOp AddrRep, - WriteOffAddrOp FloatRep, - WriteOffAddrOp DoubleRep, - WriteOffAddrOp ForeignObjRep, - WriteOffAddrOp StablePtrRep, - WriteOffAddrOp Int64Rep, - WriteOffAddrOp Word64Rep, - UnsafeFreezeArrayOp, - UnsafeFreezeByteArrayOp, - SizeofByteArrayOp, - SizeofMutableByteArrayOp, - NewMutVarOp, - ReadMutVarOp, - WriteMutVarOp, - SameMutVarOp, - CatchOp, - RaiseOp, - NewMVarOp, - TakeMVarOp, - PutMVarOp, - SameMVarOp, - MakeForeignObjOp, - WriteForeignObjOp, - MkWeakOp, - DeRefWeakOp, - MakeStablePtrOp, - DeRefStablePtrOp, - EqStablePtrOp, - ReallyUnsafePtrEqualityOp, - ParGlobalOp, - ParLocalOp, - ParAtOp, - ParAtAbsOp, - ParAtRelOp, - ParAtForNowOp, - CopyableOp, - NoFollowOp, - SeqOp, - ParOp, - ForkOp, - KillThreadOp, - DelayOp, - WaitReadOp, - WaitWriteOp - ] +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" \end{code} %************************************************************************ @@ -792,697 +102,64 @@ We use @PrimKinds@ for the ``type'' information, because they're (slightly) more convenient to use than @TyCons@. \begin{code} data PrimOpInfo - = Dyadic FAST_STRING -- string :: T -> T -> T + = Dyadic OccName -- string :: T -> T -> T Type - | Monadic FAST_STRING -- string :: T -> T + | Monadic OccName -- string :: T -> T Type - | Compare FAST_STRING -- string :: T -> T -> Bool + | Compare OccName -- string :: T -> T -> Bool Type - | GenPrimOp FAST_STRING -- string :: \/a1..an . T1 -> .. -> Tk -> T + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T [TyVar] [Type] Type -\end{code} -Utility bits: -\begin{code} -one_Integer_ty = [intPrimTy, intPrimTy, byteArrayPrimTy] -two_Integer_tys - = [intPrimTy, intPrimTy, byteArrayPrimTy, -- first Integer pieces - intPrimTy, intPrimTy, byteArrayPrimTy] -- second '' pieces -an_Integer_and_Int_tys - = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer - intPrimTy] - -unboxedPair = mkUnboxedTupleTy 2 -unboxedTriple = mkUnboxedTupleTy 3 -unboxedQuadruple = mkUnboxedTupleTy 4 -unboxedSexTuple = mkUnboxedTupleTy 6 - -integerMonadic name = GenPrimOp name [] one_Integer_ty - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -integerDyadic name = GenPrimOp name [] two_Integer_tys - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -integerDyadic2Results name = GenPrimOp name [] two_Integer_tys - (unboxedSexTuple [intPrimTy, intPrimTy, byteArrayPrimTy, - intPrimTy, intPrimTy, byteArrayPrimTy]) - -integerCompare name = GenPrimOp name [] two_Integer_tys intPrimTy +mkDyadic str ty = Dyadic (mkVarOcc str) ty +mkMonadic str ty = Monadic (mkVarOcc str) ty +mkCompare str ty = Compare (mkVarOcc str) ty +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOcc str) tvs tys ty \end{code} %************************************************************************ %* * -\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +\subsubsection{Strictness} %* * %************************************************************************ -@primOpInfo@ gives all essential information (from which everything -else, notably a type, can be constructed) for each @PrimOp@. - -\begin{code} -primOpInfo :: PrimOp -> PrimOpInfo -\end{code} - -There's plenty of this stuff! +Not all primops are strict! \begin{code} -primOpInfo CharGtOp = Compare SLIT("gtChar#") charPrimTy -primOpInfo CharGeOp = Compare SLIT("geChar#") charPrimTy -primOpInfo CharEqOp = Compare SLIT("eqChar#") charPrimTy -primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy -primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy -primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy - -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 WordEqOp = Compare SLIT("eqWord#") wordPrimTy -primOpInfo WordNeOp = Compare SLIT("neWord#") wordPrimTy -primOpInfo WordLtOp = Compare SLIT("ltWord#") wordPrimTy -primOpInfo WordLeOp = Compare SLIT("leWord#") wordPrimTy - -primOpInfo AddrGtOp = Compare SLIT("gtAddr#") addrPrimTy -primOpInfo AddrGeOp = Compare SLIT("geAddr#") addrPrimTy -primOpInfo AddrEqOp = Compare SLIT("eqAddr#") addrPrimTy -primOpInfo AddrNeOp = Compare SLIT("neAddr#") addrPrimTy -primOpInfo AddrLtOp = Compare SLIT("ltAddr#") addrPrimTy -primOpInfo AddrLeOp = Compare SLIT("leAddr#") addrPrimTy - -primOpInfo FloatGtOp = Compare SLIT("gtFloat#") floatPrimTy -primOpInfo FloatGeOp = Compare SLIT("geFloat#") floatPrimTy -primOpInfo FloatEqOp = Compare SLIT("eqFloat#") floatPrimTy -primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy -primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy -primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy - -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 - +primOpStrictness :: PrimOp -> Arity -> StrictSig + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" \end{code} %************************************************************************ %* * -\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s} +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} %* * %************************************************************************ -\begin{code} -primOpInfo OrdOp = GenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy -primOpInfo ChrOp = GenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s} -%* * -%************************************************************************ +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. \begin{code} -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 +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" \end{code} -%************************************************************************ -%* * -\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s} -%* * -%************************************************************************ +Here are a load of comments from the old primOp info: A @Word#@ is an unsigned @Int#@. -\begin{code} -primOpInfo WordQuotOp = Dyadic SLIT("quotWord#") wordPrimTy -primOpInfo WordRemOp = Dyadic SLIT("remWord#") wordPrimTy - -primOpInfo AndOp = Dyadic SLIT("and#") wordPrimTy -primOpInfo OrOp = Dyadic SLIT("or#") wordPrimTy -primOpInfo XorOp = Dyadic SLIT("xor#") wordPrimTy -primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy - -primOpInfo SllOp - = GenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy -primOpInfo SrlOp - = GenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy - -primOpInfo ISllOp - = GenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy -primOpInfo ISraOp - = GenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy -primOpInfo ISrlOp - = GenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy - -primOpInfo Int2WordOp = GenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy -primOpInfo Word2IntOp = GenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s} -%* * -%************************************************************************ - -\begin{code} -primOpInfo Int2AddrOp = GenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy -primOpInfo Addr2IntOp = GenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy -\end{code} - - -%************************************************************************ -%* * -\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s} -%* * -%************************************************************************ - -@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's -similar). - -\begin{code} -primOpInfo FloatAddOp = Dyadic SLIT("plusFloat#") floatPrimTy -primOpInfo FloatSubOp = Dyadic SLIT("minusFloat#") floatPrimTy -primOpInfo FloatMulOp = Dyadic SLIT("timesFloat#") floatPrimTy -primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy -primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy - -primOpInfo Float2IntOp = GenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy -primOpInfo Int2FloatOp = GenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy - -primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy -primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy -primOpInfo FloatSqrtOp = Monadic SLIT("sqrtFloat#") floatPrimTy -primOpInfo FloatSinOp = Monadic SLIT("sinFloat#") floatPrimTy -primOpInfo FloatCosOp = Monadic SLIT("cosFloat#") floatPrimTy -primOpInfo FloatTanOp = Monadic SLIT("tanFloat#") floatPrimTy -primOpInfo FloatAsinOp = Monadic SLIT("asinFloat#") floatPrimTy -primOpInfo FloatAcosOp = Monadic SLIT("acosFloat#") floatPrimTy -primOpInfo FloatAtanOp = Monadic SLIT("atanFloat#") floatPrimTy -primOpInfo FloatSinhOp = Monadic SLIT("sinhFloat#") floatPrimTy -primOpInfo FloatCoshOp = Monadic SLIT("coshFloat#") floatPrimTy -primOpInfo FloatTanhOp = Monadic SLIT("tanhFloat#") floatPrimTy -primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s} -%* * -%************************************************************************ - -@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's -similar). - -\begin{code} -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 = GenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy -primOpInfo Int2DoubleOp = GenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy - -primOpInfo Double2FloatOp = GenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy -primOpInfo Float2DoubleOp = GenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy - -primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy -primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy -primOpInfo DoubleSqrtOp = Monadic SLIT("sqrtDouble#") doublePrimTy -primOpInfo DoubleSinOp = Monadic SLIT("sinDouble#") doublePrimTy -primOpInfo DoubleCosOp = Monadic SLIT("cosDouble#") doublePrimTy -primOpInfo DoubleTanOp = Monadic SLIT("tanDouble#") doublePrimTy -primOpInfo DoubleAsinOp = Monadic SLIT("asinDouble#") doublePrimTy -primOpInfo DoubleAcosOp = Monadic SLIT("acosDouble#") doublePrimTy -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("**##") doublePrimTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)} -%* * -%************************************************************************ +@decodeFloat#@ is given w/ Integer-stuff (it's similar). -\begin{code} -primOpInfo IntegerNegOp = integerMonadic SLIT("negateInteger#") - -primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#") -primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#") -primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#") -primOpInfo IntegerGcdOp = integerDyadic SLIT("gcdInteger#") - -primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#") - -primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#") -primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#") - -primOpInfo Integer2IntOp - = GenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy - -primOpInfo Integer2WordOp - = GenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy - -primOpInfo Int2IntegerOp - = GenPrimOp SLIT("int2Integer#") [] [intPrimTy] - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -primOpInfo Word2IntegerOp - = GenPrimOp SLIT("word2Integer#") [] [wordPrimTy] - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -primOpInfo Addr2IntegerOp - = GenPrimOp SLIT("addr2Integer#") [] [addrPrimTy] - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -primOpInfo IntegerToInt64Op - = GenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy - -primOpInfo Int64ToIntegerOp - = GenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy] - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -primOpInfo Word64ToIntegerOp - = GenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy] - (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) - -primOpInfo IntegerToWord64Op - = GenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy -\end{code} +@decodeDouble#@ is given w/ Integer-stuff (it's similar). -Encoding and decoding of floating-point numbers is sorta -Integer-related. - -\begin{code} -primOpInfo FloatEncodeOp - = GenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy - -primOpInfo DoubleEncodeOp - = GenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy - -primOpInfo FloatDecodeOp - = GenPrimOp SLIT("decodeFloat#") [] [floatPrimTy] - (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy]) -primOpInfo DoubleDecodeOp - = GenPrimOp SLIT("decodeDouble#") [] [doublePrimTy] - (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy]) -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays} -%* * -%************************************************************************ - -\begin{code} -primOpInfo NewArrayOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("newArray#") [s_tv, elt_tv] - [intPrimTy, elt, state] - (unboxedPair [state, mkMutableArrayPrimTy s elt]) - -primOpInfo (NewByteArrayOp kind) - = let - s = alphaTy; s_tv = alphaTyVar - - op_str = _PK_ ("new" ++ primRepString kind ++ "Array#") - state = mkStatePrimTy s - in - GenPrimOp op_str [s_tv] - [intPrimTy, state] - (unboxedPair [state, mkMutableByteArrayPrimTy s]) - ---------------------------------------------------------------------------- - -primOpInfo SameMutableArrayOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - mut_arr_ty = mkMutableArrayPrimTy s elt - } in - GenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty] - boolTy - -primOpInfo SameMutableByteArrayOp - = let { - s = alphaTy; s_tv = alphaTyVar; - mut_arr_ty = mkMutableByteArrayPrimTy s - } in - GenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty] - boolTy - ---------------------------------------------------------------------------- --- Primitive arrays of Haskell pointers: - -primOpInfo ReadArrayOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("readArray#") [s_tv, elt_tv] - [mkMutableArrayPrimTy s elt, intPrimTy, state] - (unboxedPair [state, elt]) - - -primOpInfo WriteArrayOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - } in - GenPrimOp SLIT("writeArray#") [s_tv, elt_tv] - [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s] - (mkStatePrimTy s) - -primOpInfo IndexArrayOp - = let { elt = alphaTy; elt_tv = alphaTyVar } in - GenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] - (unboxedPair [realWorldStatePrimTy, elt]) - ---------------------------------------------------------------------------- --- Primitive arrays full of unboxed bytes: - -primOpInfo (ReadByteArrayOp kind) - = let - s = alphaTy; s_tv = alphaTyVar - - op_str = _PK_ ("read" ++ primRepString kind ++ "Array#") - relevant_type = assoc "primOpInfo{ReadByteArrayOp}" tbl kind - state = mkStatePrimTy s - - tvs - | kind == StablePtrRep = [s_tv, betaTyVar] - | otherwise = [s_tv] - in - GenPrimOp op_str tvs - [mkMutableByteArrayPrimTy s, intPrimTy, state] - (unboxedPair [state, relevant_type]) - where - tbl = [ (CharRep, charPrimTy), - (IntRep, intPrimTy), - (WordRep, wordPrimTy), - (AddrRep, addrPrimTy), - (FloatRep, floatPrimTy), - (StablePtrRep, mkStablePtrPrimTy betaTy), - (DoubleRep, doublePrimTy) ] - - -- How come there's no Word byte arrays? ADR - -primOpInfo (WriteByteArrayOp kind) - = let - s = alphaTy; s_tv = alphaTyVar - op_str = _PK_ ("write" ++ primRepString kind ++ "Array#") - prim_ty = mkTyConApp (primRepTyCon kind) [] - - (the_prim_ty, tvs) - | kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar]) - | otherwise = (prim_ty, [s_tv]) - - in - GenPrimOp op_str tvs - [mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s] - (mkStatePrimTy s) - -primOpInfo (IndexByteArrayOp kind) - = let - op_str = _PK_ ("index" ++ primRepString kind ++ "Array#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([],[]) - in - GenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) - -primOpInfo (IndexOffForeignObjOp kind) - = let - op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([], []) - in - GenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) - -primOpInfo (IndexOffAddrOp kind) - = let - op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#") - - (prim_tycon_args, tvs) - | kind == StablePtrRep = ([alphaTy], [alphaTyVar]) - | otherwise = ([], []) - in - GenPrimOp op_str tvs [addrPrimTy, intPrimTy] - (mkTyConApp (primRepTyCon kind) prim_tycon_args) - -primOpInfo (WriteOffAddrOp kind) - = let - s = alphaTy; s_tv = alphaTyVar - op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#") - prim_ty = mkTyConApp (primRepTyCon kind) [] - in - GenPrimOp op_str [s_tv] - [addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s] - (mkStatePrimTy s) - ---------------------------------------------------------------------------- -primOpInfo UnsafeFreezeArrayOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv] - [mkMutableArrayPrimTy s elt, state] - (unboxedPair [state, mkArrayPrimTy elt]) - -primOpInfo UnsafeFreezeByteArrayOp - = let { - s = alphaTy; s_tv = alphaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv] - [mkMutableByteArrayPrimTy s, state] - (unboxedPair [state, byteArrayPrimTy]) - ---------------------------------------------------------------------------- -primOpInfo SizeofByteArrayOp - = GenPrimOp - SLIT("sizeofByteArray#") [] - [byteArrayPrimTy] - intPrimTy - -primOpInfo SizeofMutableByteArrayOp - = let { s = alphaTy; s_tv = alphaTyVar } in - GenPrimOp - SLIT("sizeofMutableByteArray#") [s_tv] - [mkMutableByteArrayPrimTy s] - intPrimTy -\end{code} - - -%************************************************************************ -%* * -\subsubsection[PrimOp-MutVars]{PrimOpInfo for mutable variable ops} -%* * -%************************************************************************ - -\begin{code} -primOpInfo NewMutVarOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("newMutVar#") [s_tv, elt_tv] - [elt, state] - (unboxedPair [state, mkMutVarPrimTy s elt]) - -primOpInfo ReadMutVarOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - state = mkStatePrimTy s - } in - GenPrimOp SLIT("readMutVar#") [s_tv, elt_tv] - [mkMutVarPrimTy s elt, state] - (unboxedPair [state, elt]) - - -primOpInfo WriteMutVarOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - } in - GenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv] - [mkMutVarPrimTy s elt, elt, mkStatePrimTy s] - (mkStatePrimTy s) - -primOpInfo SameMutVarOp - = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; - mut_var_ty = mkMutVarPrimTy s elt - } in - GenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty] - boolTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Exceptions]{PrimOpInfo for exceptions} -%* * -%************************************************************************ - -catch :: IO a -> (IOError -> IO a) -> IO a -catch :: a -> (b -> a) -> a - -\begin{code} -primOpInfo CatchOp - = let - a = alphaTy; a_tv = alphaTyVar; - b = betaTy; b_tv = betaTyVar; - in - GenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a - -primOpInfo RaiseOp - = let - a = alphaTy; a_tv = alphaTyVar; - b = betaTy; b_tv = betaTyVar; - in - GenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-MVars]{PrimOpInfo for synchronizing Variables} -%* * -%************************************************************************ - -\begin{code} -primOpInfo NewMVarOp - = let - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - state = mkStatePrimTy s - in - GenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state] - (unboxedPair [state, mkMVarPrimTy s elt]) - -primOpInfo TakeMVarOp - = let - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - state = mkStatePrimTy s - in - GenPrimOp SLIT("takeMVar#") [s_tv, elt_tv] - [mkMVarPrimTy s elt, state] - (unboxedPair [state, elt]) - -primOpInfo PutMVarOp - = let - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - in - GenPrimOp SLIT("putMVar#") [s_tv, elt_tv] - [mkMVarPrimTy s elt, elt, mkStatePrimTy s] - (mkStatePrimTy s) - -primOpInfo SameMVarOp - = let - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar - mvar_ty = mkMVarPrimTy s elt - in - GenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations} -%* * -%************************************************************************ - -\begin{code} - -primOpInfo DelayOp - = let { - s = alphaTy; s_tv = alphaTyVar - } in - GenPrimOp SLIT("delay#") [s_tv] - [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) - -primOpInfo WaitReadOp - = let { - s = alphaTy; s_tv = alphaTyVar - } in - GenPrimOp SLIT("waitRead#") [s_tv] - [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) - -primOpInfo WaitWriteOp - = let { - s = alphaTy; s_tv = alphaTyVar - } in - GenPrimOp SLIT("waitWrite#") [s_tv] - [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-Concurrency]{Concurrency Primitives} -%* * -%************************************************************************ - -\begin{code} --- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) -primOpInfo ForkOp - = GenPrimOp SLIT("fork#") [alphaTyVar] - [alphaTy, realWorldStatePrimTy] - (unboxedPair [realWorldStatePrimTy, threadIdPrimTy]) - --- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld -primOpInfo KillThreadOp - = GenPrimOp SLIT("killThread#") [] - [threadIdPrimTy, realWorldStatePrimTy] - realWorldStatePrimTy -\end{code} - -************************************************************************ -%* * -\subsubsection[PrimOps-Foreign]{PrimOpInfo for Foreign Objects} -%* * -%************************************************************************ - -\begin{code} -primOpInfo MakeForeignObjOp - = GenPrimOp SLIT("makeForeignObj#") [] - [addrPrimTy, realWorldStatePrimTy] - (unboxedPair [realWorldStatePrimTy, foreignObjPrimTy]) - -primOpInfo WriteForeignObjOp - = let { - s = alphaTy; s_tv = alphaTyVar - } in - GenPrimOp SLIT("writeForeignObj#") [s_tv] - [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s) -\end{code} - -************************************************************************ -%* * -\subsubsection[PrimOps-Weak]{PrimOpInfo for Weak Pointers} -%* * -%************************************************************************ +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.lhs). A @Weak@ Pointer is created by the @mkWeak#@ primitive: @@ -1494,15 +171,8 @@ In practice, you'll use the higher-level data Weak v = Weak# v mkWeak :: k -> v -> IO () -> IO (Weak v) -\begin{code} -primOpInfo MkWeakOp - = GenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar] - [alphaTy, betaTy, gammaTy, realWorldStatePrimTy] - (unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy]) -\end{code} - The following operation dereferences a weak pointer. The weak pointer -may have been finalised, so the operation returns a result code which +may have been finalized, so the operation returns a result code which must be inspected before looking at the dereferenced value. deRefWeak# :: Weak# v -> State# RealWorld -> @@ -1514,267 +184,183 @@ The higher-level op is deRefWeak :: Weak v -> IO (Maybe v) -\begin{code} -primOpInfo DeRefWeakOp - = GenPrimOp SLIT("deRefWeak#") [alphaTyVar] - [mkWeakPrimTy alphaTy, realWorldStatePrimTy] - (unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy]) -\end{code} +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) -%************************************************************************ -%* * -\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''} -%* * -%************************************************************************ +The Int# returned is either -A {\em stable pointer} is an index into a table of pointers into the -heap. Since the garbage collector is told about stable pointers, it -is safe to pass a stable pointer to external systems such as C -routines. + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. -Here's what the operations and types are supposed to be (from -state-interface document). +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. \begin{verbatim} -makeStablePtr# :: a -> State# _RealWorld -> (# State# _RealWorld, a #) -freeStablePtr# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld -deRefStablePtr# :: StablePtr# 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# \end{verbatim} -It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@ +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ operation since it doesn't (directly) involve IO operations. The reason is that if some optimisation pass decided to duplicate calls to @makeStablePtr#@ and we only pass one of the stable pointers over, a -massive space leak can result. Putting it into the PrimIO monad +massive space leak can result. Putting it into the IO monad prevents this. (Another reason for putting them in a monad is to -ensure correct sequencing wrt the side-effecting @freeStablePtr#@ +ensure correct sequencing wrt the side-effecting @freeStablePtr@ operation.) +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, besides, it's not likely to be used from Haskell) so it's not a primop. -Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR] +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] -\begin{code} -primOpInfo MakeStablePtrOp - = GenPrimOp SLIT("makeStablePtr#") [alphaTyVar] - [alphaTy, realWorldStatePrimTy] - (unboxedPair [realWorldStatePrimTy, - mkTyConApp stablePtrPrimTyCon [alphaTy]]) - -primOpInfo DeRefStablePtrOp - = GenPrimOp SLIT("deRefStablePtr#") [alphaTyVar] - [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy] - (unboxedPair [realWorldStatePrimTy, alphaTy]) - -primOpInfo EqStablePtrOp - = GenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar] - [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy] - intPrimTy -\end{code} +Stable Names +~~~~~~~~~~~~ -%************************************************************************ -%* * -\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality} -%* * -%************************************************************************ +A stable name is like a stable pointer, but with three important differences: -[Alastair Reid is to blame for this!] + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' -These days, (Glasgow) Haskell seems to have a bit of everything from -other languages: strict operations, mutable variables, sequencing, -pointers, etc. About the only thing left is LISP's ability to test -for pointer equality. So, let's add it in! +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). -\begin{verbatim} -reallyUnsafePtrEquality :: a -> a -> Int# -\end{verbatim} - -which tests any two closures (of the same type) to see if they're the -same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid -difficulties of trying to box up the result.) - -NB This is {\em really unsafe\/} because even something as trivial as -a garbage collection might change the answer by removing indirections. -Still, no-one's forcing you to use it. If you're worried about little -things like loss of referential transparency, you might like to wrap -it all up in a monad-like thing as John O'Donnell and John Hughes did -for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop -Proceedings?) - -I'm thinking of using it to speed up a critical equality test in some -graphics stuff in a context where the possibility of saying that -denotationally equal things aren't isn't a problem (as long as it -doesn't happen too often.) ADR - -To Will: Jim said this was already in, but I can't see it so I'm -adding it. Up to you whether you add it. (Note that this could have -been readily implemented using a @veryDangerousCCall@ before they were -removed...) - -\begin{code} -primOpInfo ReallyUnsafePtrEqualityOp - = GenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar] - [alphaTy, alphaTy] intPrimTy -\end{code} +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). -%************************************************************************ -%* * -\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)} -%* * -%************************************************************************ + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. -\begin{code} -primOpInfo SeqOp -- seq# :: a -> Int# - = GenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy + (c) stableNameToInt always returns the same Int for a given + stable name. -primOpInfo ParOp -- par# :: a -> Int# - = GenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy -\end{code} -\begin{code} -- 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 - = GenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy - -primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b - = GenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy - -primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c - = GenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy +These primops are pretty wierd. -primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b - = GenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy + dataToTag# :: a -> Int (arg must be an evaluated data type) + tagToEnum# :: Int -> a (result type must be an enumerated type) -primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b - = GenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. -primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c - = GenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy - -primOpInfo CopyableOp -- copyable# :: a -> a - = GenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy - -primOpInfo NoFollowOp -- noFollow# :: a -> a - = GenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy +\begin{code} +#ifdef DEBUG +primOpInfo op = pprPanic "primOpInfo:" (ppr op) +#endif \end{code} %************************************************************************ %* * -\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things} +\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line} %* * %************************************************************************ -\begin{code} -primOpInfo (CCallOp _ _ _ _) - = GenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy - -{- -primOpInfo (CCallOp _ _ _ _ arg_tys result_ty) - = GenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied - where - (result_tycon, tys_applied, _) = splitAlgTyConApp result_ty --} -#ifdef DEBUG -primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op))) -#endif -\end{code} - Some PrimOps need to be called out-of-line because they either need to perform a heap check or they block. + \begin{code} -primOpOutOfLine op - = case op of - TakeMVarOp -> True - PutMVarOp -> True - DelayOp -> True - WaitReadOp -> True - WaitWriteOp -> True - CatchOp -> True - RaiseOp -> True - NewArrayOp -> True - NewByteArrayOp _ -> True - IntegerAddOp -> True - IntegerSubOp -> True - IntegerMulOp -> True - IntegerGcdOp -> True - IntegerQuotRemOp -> True - IntegerDivModOp -> True - Int2IntegerOp -> True - Word2IntegerOp -> True - Addr2IntegerOp -> True - Word64ToIntegerOp -> True - Int64ToIntegerOp -> True - FloatDecodeOp -> True - DoubleDecodeOp -> True - MkWeakOp -> True - DeRefWeakOp -> True - MakeForeignObjOp -> True - MakeStablePtrOp -> True - NewMutVarOp -> True - NewMVarOp -> True - ForkOp -> True - KillThreadOp -> True - CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_ - _ -> False +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" \end{code} + +primOpOkForSpeculation +~~~~~~~~~~~~~~~~~~~~~~ Sometimes we may choose to execute a PrimOp even though it isn't certain that its result will be required; ie execute them ``speculatively''. The same thing as ``cheap eagerness.'' Usually this is OK, because PrimOps are usually cheap, but it isn't OK for (a)~expensive PrimOps and (b)~PrimOps which can fail. +PrimOps that have side effects also should not be executed speculatively. + +Ok-for-speculation also means that it's ok *not* to execute the +primop. For example + case op a b of + r -> 3 +Here the result is not used, so we can discard the primop. Anything +that has side effects mustn't be dicarded in this way, of course! + See also @primOpIsCheap@ (below). -PrimOps that have side effects also should not be executed speculatively -or by data dependencies. \begin{code} primOpOkForSpeculation :: PrimOp -> Bool + -- See comments with CoreUtils.exprOkForSpeculation primOpOkForSpeculation op - = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op) + = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) \end{code} + +primOpIsCheap +~~~~~~~~~~~~~ @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. "Cheap" means willing to call it more -than once. Evaluation order is unaffected. +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. \begin{code} -primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op) +primOpIsCheap :: PrimOp -> Bool +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. \end{code} +primOpIsDupable +~~~~~~~~~~~~~~~ +primOpIsDupable means that the use of the primop is small enough to +duplicate into different case branches. See CoreUtils.exprIsDupable. + +\begin{code} +primOpIsDupable :: PrimOp -> Bool + -- See comments with CoreUtils.exprIsDupable + -- We say it's dupable it isn't implemented by a C call with a wrapper +primOpIsDupable op = not (primOpNeedsWrapper op) +\end{code} + + \begin{code} primOpCanFail :: PrimOp -> Bool --- Int. -primOpCanFail IntQuotOp = True -- Divide by zero -primOpCanFail IntRemOp = True -- Divide by zero - --- Integer -primOpCanFail IntegerQuotRemOp = True -- Divide by zero -primOpCanFail IntegerDivModOp = True -- Divide by zero - --- Float. ToDo: tan? tanh? -primOpCanFail FloatDivOp = True -- Divide by zero -primOpCanFail FloatLogOp = True -- Log of zero -primOpCanFail FloatAsinOp = True -- Arg out of domain -primOpCanFail FloatAcosOp = True -- Arg out of domain - --- Double. ToDo: tan? tanh? -primOpCanFail DoubleDivOp = True -- Divide by zero -primOpCanFail DoubleLogOp = True -- Log of zero -primOpCanFail DoubleAsinOp = True -- Arg out of domain -primOpCanFail DoubleAcosOp = True -- Arg out of domain - --- The default is "yes it's ok for speculation" -primOpCanFail other_op = True +#include "primop-can-fail.hs-incl" \end{code} And some primops have side-effects and so, for example, must not be @@ -1782,38 +368,7 @@ duplicated. \begin{code} primOpHasSideEffects :: PrimOp -> Bool - -primOpHasSideEffects TakeMVarOp = True -primOpHasSideEffects DelayOp = True -primOpHasSideEffects WaitReadOp = True -primOpHasSideEffects WaitWriteOp = True - -primOpHasSideEffects ParOp = True -primOpHasSideEffects ForkOp = True -primOpHasSideEffects KillThreadOp = True -primOpHasSideEffects SeqOp = True - -primOpHasSideEffects MakeForeignObjOp = True -primOpHasSideEffects WriteForeignObjOp = True -primOpHasSideEffects MkWeakOp = True -primOpHasSideEffects DeRefWeakOp = True -primOpHasSideEffects MakeStablePtrOp = True -primOpHasSideEffects EqStablePtrOp = True -- SOF -primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR - -primOpHasSideEffects ParGlobalOp = True -primOpHasSideEffects ParLocalOp = True -primOpHasSideEffects ParAtOp = True -primOpHasSideEffects ParAtAbsOp = True -primOpHasSideEffects ParAtRelOp = True -primOpHasSideEffects ParAtForNowOp = True -primOpHasSideEffects CopyableOp = True -- Possibly not. ASP -primOpHasSideEffects NoFollowOp = True -- Possibly not. ASP - --- CCall -primOpHasSideEffects (CCallOp _ _ _ _) = True - -primOpHasSideEffects other = False +#include "primop-has-side-effects.hs-incl" \end{code} Inline primitive operations that perform calls need wrappers to save @@ -1821,75 +376,43 @@ any live variables that are stored in caller-saves registers. \begin{code} primOpNeedsWrapper :: PrimOp -> Bool - -primOpNeedsWrapper (CCallOp _ _ _ _) = True - -primOpNeedsWrapper Integer2IntOp = True -primOpNeedsWrapper Integer2WordOp = True -primOpNeedsWrapper IntegerCmpOp = True - -primOpNeedsWrapper FloatExpOp = True -primOpNeedsWrapper FloatLogOp = True -primOpNeedsWrapper FloatSqrtOp = True -primOpNeedsWrapper FloatSinOp = True -primOpNeedsWrapper FloatCosOp = True -primOpNeedsWrapper FloatTanOp = True -primOpNeedsWrapper FloatAsinOp = True -primOpNeedsWrapper FloatAcosOp = True -primOpNeedsWrapper FloatAtanOp = True -primOpNeedsWrapper FloatSinhOp = True -primOpNeedsWrapper FloatCoshOp = True -primOpNeedsWrapper FloatTanhOp = True -primOpNeedsWrapper FloatPowerOp = True -primOpNeedsWrapper FloatEncodeOp = True - -primOpNeedsWrapper DoubleExpOp = True -primOpNeedsWrapper DoubleLogOp = True -primOpNeedsWrapper DoubleSqrtOp = True -primOpNeedsWrapper DoubleSinOp = True -primOpNeedsWrapper DoubleCosOp = True -primOpNeedsWrapper DoubleTanOp = True -primOpNeedsWrapper DoubleAsinOp = True -primOpNeedsWrapper DoubleAcosOp = True -primOpNeedsWrapper DoubleAtanOp = True -primOpNeedsWrapper DoubleSinhOp = True -primOpNeedsWrapper DoubleCoshOp = True -primOpNeedsWrapper DoubleTanhOp = True -primOpNeedsWrapper DoublePowerOp = True -primOpNeedsWrapper DoubleEncodeOp = True - -primOpNeedsWrapper MakeStablePtrOp = True -primOpNeedsWrapper DeRefStablePtrOp = True - -primOpNeedsWrapper DelayOp = True -primOpNeedsWrapper WaitReadOp = True -primOpNeedsWrapper WaitWriteOp = True - -primOpNeedsWrapper other_op = False +#include "primop-needs-wrapper.hs-incl" \end{code} \begin{code} -primOpStr op - = case (primOpInfo op) of - Dyadic str _ -> str - Monadic str _ -> str - Compare str _ -> str - GenPrimOp str _ _ _ -> str -\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 str ty -> dyadic_fun_ty ty - Monadic str ty -> monadic_fun_ty ty - Compare str ty -> compare_fun_ty ty + Dyadic occ ty -> dyadic_fun_ty ty + Monadic occ ty -> monadic_fun_ty ty + Compare occ ty -> compare_fun_ty ty - GenPrimOp str tyvars arg_tys res_ty -> + GenPrimOp occ tyvars arg_tys res_ty -> mkForAllTys tyvars (mkFunTys arg_tys res_ty) + +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) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = 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) \end{code} \begin{code} @@ -1902,26 +425,18 @@ data PrimOpResultInfo -- 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 - GenPrimOp _ _ _ ty -> - let rep = typePrimRep ty in - case rep of - PtrRep -> case splitAlgTyConApp_maybe ty of - Nothing -> panic "getPrimOpResultInfo" - Just (tc,_,_) -> ReturnsAlg tc - other -> ReturnsPrim other - -isCompareOp :: PrimOp -> Bool - -isCompareOp op - = case primOpInfo op of - Compare _ _ -> True - _ -> False + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) + Compare _ ty -> ReturnsAlg boolTyCon + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) + | otherwise -> ReturnsAlg tc + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple, though, which + -- gives rise to a ReturnAlg \end{code} The commutable ops are those for which we will try to move constants @@ -1929,28 +444,7 @@ 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 XorOp = True -commutableOp IntEqOp = True -commutableOp IntNeOp = True -commutableOp IntegerAddOp = True -commutableOp IntegerMulOp = True -commutableOp IntegerGcdOp = 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 +#include "primop-commutable.hs-incl" \end{code} Utils: @@ -1963,38 +457,6 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} pprPrimOp :: PrimOp -> SDoc - -pprPrimOp (CCallOp fun is_casm may_gc cconv) - = let - callconv = text "{-" <> pprCallConv cconv <> text "-}" - - before - | is_casm && may_gc = "__casm_GC ``" - | is_casm = "__casm ``" - | may_gc = "__ccall_GC " - | otherwise = "__ccall " - - after - | is_casm = text "''" - | otherwise = empty - - ppr_fun = - case fun of - Right _ -> ptext SLIT("") - Left fn -> ptext fn - - in - hcat [ ifPprDebug callconv - , text before , ppr_fun , after] - -pprPrimOp other_op - = getPprStyle $ \ sty -> - if codeStyle sty then -- For C just print the primop itself - identToC str - else if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC. - ptext SLIT("PrelGHC.") <> ptext str - else -- Unqualified is good enough - ptext str - where - str = primOpStr other_op +pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} +