X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrimOp.lhs;h=1e073e44d1bc235fa0f058535614cc7c0b3293fc;hb=46de0542b6c4344ed71296db09066e0504dd00d9;hp=fd1a66651eb343372d8ddf0053c881572066ef25;hpb=d51f7ef704de2c33db43a9f384e83eac8605bb61;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index fd1a666..1e073e4 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1,54 +1,47 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[PrimOp]{Primitive operations (machine-level)} \begin{code} -#include "HsVersions.h" - module PrimOp ( PrimOp(..), allThePrimOps, tagOf_PrimOp, -- ToDo: rm - primOp_str, -- sigh - primOpType, isCompareOp, - commutableOp, + primOpType, + primOpUniq, primOpOcc, - PrimOpResultInfo(..), - getPrimOpResultInfo, + commutableOp, - primOpCanTriggerGC, primOpNeedsWrapper, + primOpOutOfLine, primOpNeedsWrapper, primOpStrictness, primOpOkForSpeculation, primOpIsCheap, - fragilePrimOp, - HeapRequirement(..), primOpHeapReq, - StackRequirement(..), primOpStackRequired, + primOpHasSideEffects, - -- export for the Native Code Generator - primOpInfo, -- needed for primOpNameInfo - PrimOpInfo(..), + getPrimOpResultInfo, PrimOpResultInfo(..), - pprPrimOp, showPrimOp + pprPrimOp ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import PrimRep -- most of it import TysPrim import TysWiredIn -import CStrings ( identToC ) -import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) -import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) -import Outputable ( PprStyle, Outputable(..), codeStyle, ifaceStyle ) -import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) -import Pretty -import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) -import TyCon ( TyCon{-instances-} ) -import Type ( mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep, - getAppDataTyConExpandingDicts, SYN_IE(Type) +import Demand ( Demand, wwLazy, wwPrim, wwStrict ) +import Var ( TyVar ) +import CallConv ( CallConv, pprCallConv ) +import PprType ( pprParendType ) +import OccName ( OccName, pprOccName, mkSrcVarOcc ) +import TyCon ( TyCon, tyConArity ) +import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys, + mkTyConTy, mkTyConApp, typePrimRep, + splitAlgTyConApp, Type, isUnboxedTupleType, + splitAlgTyConApp_maybe ) -import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) -import Unique ( Unique{-instance Eq-} ) -import Util ( panic#, assoc, panic{-ToDo:rm-} ) +import Unique ( Unique, mkPrimOpIdUnique ) +import Outputable +import Util ( assoc ) +import GlaExts ( Int(..), Int#, (==#) ) \end{code} %************************************************************************ @@ -76,14 +69,15 @@ data PrimOp | OrdOp | ChrOp -- Int#-related ops: - -- IntAbsOp unused?? ADR + -- 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 | SraOp | SrlOp -- shift {left,right} {arithmetic,logical} - | ISllOp | ISraOp | ISrlOp -- equivs on Int#s + | SllOp | SrlOp -- shift {left,right} {logical} | Int2WordOp | Word2IntOp -- casts -- Addr#-related ops: @@ -116,14 +110,17 @@ data PrimOp -- Integer (and related...) ops: -- slightly weird -- to match GMP package. - | IntegerAddOp | IntegerSubOp | IntegerMulOp + | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerGcdOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp - | Integer2IntOp | Int2IntegerOp - | Word2IntegerOp - | Addr2IntegerOp -- "Addr" is *always* a literal string + | Integer2IntOp | Integer2WordOp + | Int2IntegerOp | Word2IntegerOp + | Addr2IntegerOp + -- casting to/from Integer and 64-bit (un)signed quantities. + | IntegerToInt64Op | Int64ToIntegerOp + | IntegerToWord64Op | Word64ToIntegerOp -- ?? gcd, etc? | FloatEncodeOp | FloatDecodeOp @@ -143,6 +140,7 @@ data PrimOp | 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 @@ -150,24 +148,53 @@ data PrimOp | IndexOffForeignObjOp PrimRep | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp - - | NewSynchVarOp -- for MVars and IVars - | TakeMVarOp | PutMVarOp - | ReadIVarOp | WriteIVarOp - - | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) - | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200] - | MakeStablePtrOp | DeRefStablePtrOp + | SizeofByteArrayOp | SizeofMutableByteArrayOp + + -- Mutable variables + | NewMutVarOp + | ReadMutVarOp + | WriteMutVarOp + | SameMutVarOp + + -- for MVars + | NewMVarOp + | TakeMVarOp + | PutMVarOp + | SameMVarOp + | IsEmptyMVarOp + + -- exceptions + | CatchOp + | RaiseOp + + | MakeForeignObjOp + | WriteForeignObjOp + + | MkWeakOp + | DeRefWeakOp + | FinaliseWeakOp + + | MakeStableNameOp + | EqStableNameOp + | StableNameToIntOp + + | MakeStablePtrOp + | DeRefStablePtrOp + | EqStablePtrOp \end{code} A special ``trap-door'' to use in making calls direct to C functions: \begin{code} - | CCallOp FAST_STRING -- An "unboxed" ccall# to this named function - Bool -- True <=> really a "casm" - Bool -- True <=> might invoke Haskell GC - [Type] -- Unboxed argument; the state-token - -- argument will have been put *first* - Type -- Return type; one of the "StateAnd#" types + | 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 generate a 'typedef' to cast + -- the function pointer if compiling the ccall# down to + -- .hc code - can't do this inline for tedious reasons.) + + Bool -- True <=> really a "casm" + Bool -- True <=> might invoke Haskell GC + CallConv -- calling convention to use. -- (... to be continued ... ) \end{code} @@ -231,19 +258,17 @@ about using it this way?? ADR) \begin{code} -- (... continued from above ... ) - -- one to support "errorIO" (and, thereby, "error") - | ErrorIOPrimOp - -- Operation to test two closure addresses for equality (yes really!) -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT! | ReallyUnsafePtrEqualityOp - -- three for parallel stuff + -- parallel stuff | SeqOp | ParOp - | ForkOp - -- three for concurrency + -- concurrency + | ForkOp + | KillThreadOp | DelayOp | WaitReadOp | WaitWriteOp @@ -258,10 +283,10 @@ about using it this way?? ADR) | NoFollowOp -- marks non-followup expression \end{code} -Deriving Ix is what we really want! ToDo -(Chk around before deleting...) +Used for the Ord instance + \begin{code} -tagOf_PrimOp CharGtOp = (ILIT(1) :: FAST_INT) +tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT) tagOf_PrimOp CharGeOp = ILIT( 2) tagOf_PrimOp CharEqOp = ILIT( 3) tagOf_PrimOp CharNeOp = ILIT( 4) @@ -303,15 +328,16 @@ tagOf_PrimOp IntAddOp = ILIT( 39) tagOf_PrimOp IntSubOp = ILIT( 40) tagOf_PrimOp IntMulOp = ILIT( 41) tagOf_PrimOp IntQuotOp = ILIT( 42) -tagOf_PrimOp IntRemOp = ILIT( 44) -tagOf_PrimOp IntNegOp = ILIT( 45) -tagOf_PrimOp IntAbsOp = ILIT( 46) -tagOf_PrimOp AndOp = ILIT( 47) -tagOf_PrimOp OrOp = ILIT( 48) -tagOf_PrimOp NotOp = ILIT( 49) -tagOf_PrimOp XorOp = ILIT( 50) -tagOf_PrimOp SllOp = ILIT( 51) -tagOf_PrimOp SraOp = ILIT( 52) +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) @@ -320,6 +346,7 @@ 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) @@ -340,6 +367,7 @@ 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) @@ -362,91 +390,168 @@ 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 IntegerQuotRemOp = ILIT(106) -tagOf_PrimOp IntegerDivModOp = ILIT(107) -tagOf_PrimOp IntegerNegOp = ILIT(108) -tagOf_PrimOp IntegerCmpOp = ILIT(109) -tagOf_PrimOp Integer2IntOp = ILIT(110) -tagOf_PrimOp Int2IntegerOp = ILIT(111) -tagOf_PrimOp Word2IntegerOp = ILIT(112) -tagOf_PrimOp Addr2IntegerOp = ILIT(113) -tagOf_PrimOp FloatEncodeOp = ILIT(114) -tagOf_PrimOp FloatDecodeOp = ILIT(115) -tagOf_PrimOp DoubleEncodeOp = ILIT(116) -tagOf_PrimOp DoubleDecodeOp = ILIT(117) -tagOf_PrimOp NewArrayOp = ILIT(118) -tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(119) -tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(120) -tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(121) -tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(122) -tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(123) -tagOf_PrimOp SameMutableArrayOp = ILIT(124) -tagOf_PrimOp SameMutableByteArrayOp = ILIT(125) -tagOf_PrimOp ReadArrayOp = ILIT(126) -tagOf_PrimOp WriteArrayOp = ILIT(127) -tagOf_PrimOp IndexArrayOp = ILIT(128) -tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(129) -tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(130) -tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(131) -tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(132) -tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(133) -tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(134) -tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(135) -tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(136) -tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(137) -tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(138) -tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(139) -tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(140) -tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(141) -tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(142) -tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(143) -tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(144) -tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(145) -tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(146) -tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(147) -tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(148) -tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(149) -tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(150) -tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(151) -tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(152) -tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(153) -tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(154) -tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(155) -tagOf_PrimOp NewSynchVarOp = ILIT(156) -tagOf_PrimOp TakeMVarOp = ILIT(157) -tagOf_PrimOp PutMVarOp = ILIT(158) -tagOf_PrimOp ReadIVarOp = ILIT(159) -tagOf_PrimOp WriteIVarOp = ILIT(160) -tagOf_PrimOp MakeForeignObjOp = ILIT(161) -tagOf_PrimOp WriteForeignObjOp = ILIT(162) -tagOf_PrimOp MakeStablePtrOp = ILIT(163) -tagOf_PrimOp DeRefStablePtrOp = ILIT(164) -tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(165) -tagOf_PrimOp ErrorIOPrimOp = ILIT(166) -tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(167) -tagOf_PrimOp SeqOp = ILIT(168) -tagOf_PrimOp ParOp = ILIT(169) -tagOf_PrimOp ForkOp = ILIT(170) -tagOf_PrimOp DelayOp = ILIT(171) -tagOf_PrimOp WaitReadOp = ILIT(172) -tagOf_PrimOp WaitWriteOp = ILIT(173) - -tagOf_PrimOp ParGlobalOp = ILIT(174) -tagOf_PrimOp ParLocalOp = ILIT(175) -tagOf_PrimOp ParAtOp = ILIT(176) -tagOf_PrimOp ParAtAbsOp = ILIT(177) -tagOf_PrimOp ParAtRelOp = ILIT(178) -tagOf_PrimOp ParAtForNowOp = ILIT(179) -tagOf_PrimOp CopyableOp = ILIT(180) -tagOf_PrimOp NoFollowOp = ILIT(181) - -tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match" +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 IsEmptyMVarOp = ILIT(200) +tagOf_PrimOp MakeForeignObjOp = ILIT(201) +tagOf_PrimOp WriteForeignObjOp = ILIT(202) +tagOf_PrimOp MkWeakOp = ILIT(203) +tagOf_PrimOp DeRefWeakOp = ILIT(204) +tagOf_PrimOp FinaliseWeakOp = ILIT(205) +tagOf_PrimOp MakeStableNameOp = ILIT(206) +tagOf_PrimOp EqStableNameOp = ILIT(207) +tagOf_PrimOp StableNameToIntOp = ILIT(208) +tagOf_PrimOp MakeStablePtrOp = ILIT(209) +tagOf_PrimOp DeRefStablePtrOp = ILIT(210) +tagOf_PrimOp EqStablePtrOp = ILIT(211) +tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(212) +tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(213) +tagOf_PrimOp SeqOp = ILIT(214) +tagOf_PrimOp ParOp = ILIT(215) +tagOf_PrimOp ForkOp = ILIT(216) +tagOf_PrimOp KillThreadOp = ILIT(217) +tagOf_PrimOp DelayOp = ILIT(218) +tagOf_PrimOp WaitReadOp = ILIT(219) +tagOf_PrimOp WaitWriteOp = ILIT(220) +tagOf_PrimOp ParGlobalOp = ILIT(221) +tagOf_PrimOp ParLocalOp = ILIT(222) +tagOf_PrimOp ParAtOp = ILIT(223) +tagOf_PrimOp ParAtAbsOp = ILIT(224) +tagOf_PrimOp ParAtRelOp = ILIT(225) +tagOf_PrimOp ParAtForNowOp = ILIT(226) +tagOf_PrimOp CopyableOp = ILIT(227) +tagOf_PrimOp NoFollowOp = ILIT(228) +tagOf_PrimOp NewMutVarOp = ILIT(229) +tagOf_PrimOp ReadMutVarOp = ILIT(230) +tagOf_PrimOp WriteMutVarOp = ILIT(231) +tagOf_PrimOp SameMutVarOp = ILIT(232) +tagOf_PrimOp CatchOp = ILIT(233) +tagOf_PrimOp RaiseOp = ILIT(234) + +tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) +--panic# "tagOf_PrimOp: pattern-match" instance Eq PrimOp where - op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2 + op1 == op2 = tagOf_PrimOp op1 _EQ_ 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 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +instance Show PrimOp where + showsPrec p op = showsPrecSDoc p (pprPrimOp op) \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) @@ -496,12 +601,13 @@ allThePrimOps IntQuotOp, IntRemOp, IntNegOp, + WordQuotOp, + WordRemOp, AndOp, OrOp, NotOp, XorOp, SllOp, - SraOp, SrlOp, ISllOp, ISraOp, @@ -510,6 +616,7 @@ allThePrimOps Word2IntOp, Int2AddrOp, Addr2IntOp, + FloatAddOp, FloatSubOp, FloatMulOp, @@ -555,14 +662,20 @@ allThePrimOps IntegerAddOp, IntegerSubOp, IntegerMulOp, + IntegerGcdOp, IntegerQuotRemOp, IntegerDivModOp, IntegerNegOp, IntegerCmpOp, Integer2IntOp, + Integer2WordOp, Int2IntegerOp, Word2IntegerOp, Addr2IntegerOp, + IntegerToInt64Op, + Int64ToIntegerOp, + IntegerToWord64Op, + Word64ToIntegerOp, FloatEncodeOp, FloatDecodeOp, DoubleEncodeOp, @@ -570,9 +683,11 @@ allThePrimOps NewArrayOp, NewByteArrayOp CharRep, NewByteArrayOp IntRep, + NewByteArrayOp WordRep, NewByteArrayOp AddrRep, NewByteArrayOp FloatRep, NewByteArrayOp DoubleRep, + NewByteArrayOp StablePtrRep, SameMutableArrayOp, SameMutableByteArrayOp, ReadArrayOp, @@ -580,43 +695,86 @@ allThePrimOps 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, - IndexOffForeignObjOp CharRep, - IndexOffForeignObjOp IntRep, - IndexOffForeignObjOp AddrRep, - IndexOffForeignObjOp FloatRep, - IndexOffForeignObjOp 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, - NewSynchVarOp, - ReadArrayOp, + SizeofByteArrayOp, + SizeofMutableByteArrayOp, + NewMutVarOp, + ReadMutVarOp, + WriteMutVarOp, + SameMutVarOp, + CatchOp, + RaiseOp, + NewMVarOp, TakeMVarOp, PutMVarOp, - ReadIVarOp, - WriteIVarOp, + SameMVarOp, + IsEmptyMVarOp, MakeForeignObjOp, WriteForeignObjOp, + MkWeakOp, + DeRefWeakOp, + FinaliseWeakOp, + MakeStableNameOp, + EqStableNameOp, + StableNameToIntOp, MakeStablePtrOp, DeRefStablePtrOp, + EqStablePtrOp, ReallyUnsafePtrEqualityOp, - ErrorIOPrimOp, ParGlobalOp, ParLocalOp, ParAtOp, @@ -628,6 +786,7 @@ allThePrimOps SeqOp, ParOp, ForkOp, + KillThreadOp, DelayOp, WaitReadOp, WaitWriteOp @@ -651,29 +810,22 @@ 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 - Type - | Compare FAST_STRING -- string :: T -> T -> Bool - Type - | Coercing FAST_STRING -- string :: T1 -> T2 + | Monadic OccName -- string :: T -> T Type + | Compare OccName -- string :: T -> T -> Bool Type - | PrimResult FAST_STRING - [TyVar] [Type] TyCon PrimRep [Type] - -- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]" - -- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm) - -- D# is a primitive type constructor. - -- (the kind is the same info as D#, in another convenient form) + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type - | AlgResult FAST_STRING - [TyVar] [Type] TyCon [Type] - -- "AlgResult tvs [t1,..,tn] T [s1,..,sm]" - -- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm) - --- ToDo: Specialised calls to PrimOps are prohibited but may be desirable +mkDyadic str ty = Dyadic (mkSrcVarOcc str) ty +mkMonadic str ty = Monadic (mkSrcVarOcc str) ty +mkCompare str ty = Compare (mkSrcVarOcc str) ty +mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty \end{code} Utility bits: @@ -686,23 +838,61 @@ an_Integer_and_Int_tys = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer intPrimTy] -integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon [] +unboxedPair = mkUnboxedTupleTy 2 +unboxedTriple = mkUnboxedTupleTy 3 +unboxedQuadruple = mkUnboxedTupleTy 4 +unboxedSexTuple = mkUnboxedTupleTy 6 + +integerMonadic name = mkGenPrimOp name [] one_Integer_ty + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) -integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon [] +integerDyadic name = mkGenPrimOp name [] two_Integer_tys + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) -integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon [] +integerDyadic2Results name = mkGenPrimOp name [] two_Integer_tys + (unboxedSexTuple [intPrimTy, intPrimTy, byteArrayPrimTy, + intPrimTy, intPrimTy, byteArrayPrimTy]) -integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntRep [] +integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy \end{code} -@primOpInfo@ gives all essential information (from which everything -else, notably a type, can be constructed) for each @PrimOp@. +%************************************************************************ +%* * +\subsubsection{Strictness} +%* * +%************************************************************************ + +Not all primops are strict! \begin{code} -primOpInfo :: PrimOp -> PrimOpInfo -\end{code} +primOpStrictness :: PrimOp -> ([Demand], Bool) + -- See IdInfo.StrictnessInfo for discussion of what the results + -- **NB** as a cheap hack, to avoid having to look up the PrimOp's arity, + -- the list of demands may be infinite! + -- Use only the ones you ned. -There's plenty of this stuff! +primOpStrictness SeqOp = ([wwLazy], False) +primOpStrictness ParOp = ([wwLazy], False) +primOpStrictness ForkOp = ([wwLazy, wwPrim], False) + +primOpStrictness NewArrayOp = ([wwPrim, wwLazy, wwPrim], False) +primOpStrictness WriteArrayOp = ([wwPrim, wwPrim, wwLazy, wwPrim], False) + +primOpStrictness NewMutVarOp = ([wwLazy, wwPrim], False) +primOpStrictness WriteMutVarOp = ([wwPrim, wwLazy, wwPrim], False) + +primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False) + +primOpStrictness CatchOp = ([wwLazy, wwLazy], False) +primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom + +primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False) +primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False) +primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False) + + -- The rest all have primitive-typed arguments +primOpStrictness other = (repeat wwPrim, False) +\end{code} %************************************************************************ %* * @@ -710,48 +900,58 @@ There's plenty of this stuff! %* * %************************************************************************ +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. + \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 +primOpInfo :: PrimOp -> PrimOpInfo +\end{code} + +There's plenty of this stuff! + +\begin{code} +primOpInfo CharGtOp = mkCompare SLIT("gtChar#") charPrimTy +primOpInfo CharGeOp = mkCompare SLIT("geChar#") charPrimTy +primOpInfo CharEqOp = mkCompare SLIT("eqChar#") charPrimTy +primOpInfo CharNeOp = mkCompare SLIT("neChar#") charPrimTy +primOpInfo CharLtOp = mkCompare SLIT("ltChar#") charPrimTy +primOpInfo CharLeOp = mkCompare SLIT("leChar#") charPrimTy + +primOpInfo IntGtOp = mkCompare SLIT(">#") intPrimTy +primOpInfo IntGeOp = mkCompare SLIT(">=#") intPrimTy +primOpInfo IntEqOp = mkCompare SLIT("==#") intPrimTy +primOpInfo IntNeOp = mkCompare SLIT("/=#") intPrimTy +primOpInfo IntLtOp = mkCompare SLIT("<#") intPrimTy +primOpInfo IntLeOp = mkCompare SLIT("<=#") intPrimTy + +primOpInfo WordGtOp = mkCompare SLIT("gtWord#") wordPrimTy +primOpInfo WordGeOp = mkCompare SLIT("geWord#") wordPrimTy +primOpInfo WordEqOp = mkCompare SLIT("eqWord#") wordPrimTy +primOpInfo WordNeOp = mkCompare SLIT("neWord#") wordPrimTy +primOpInfo WordLtOp = mkCompare SLIT("ltWord#") wordPrimTy +primOpInfo WordLeOp = mkCompare SLIT("leWord#") wordPrimTy + +primOpInfo AddrGtOp = mkCompare SLIT("gtAddr#") addrPrimTy +primOpInfo AddrGeOp = mkCompare SLIT("geAddr#") addrPrimTy +primOpInfo AddrEqOp = mkCompare SLIT("eqAddr#") addrPrimTy +primOpInfo AddrNeOp = mkCompare SLIT("neAddr#") addrPrimTy +primOpInfo AddrLtOp = mkCompare SLIT("ltAddr#") addrPrimTy +primOpInfo AddrLeOp = mkCompare SLIT("leAddr#") addrPrimTy + +primOpInfo FloatGtOp = mkCompare SLIT("gtFloat#") floatPrimTy +primOpInfo FloatGeOp = mkCompare SLIT("geFloat#") floatPrimTy +primOpInfo FloatEqOp = mkCompare SLIT("eqFloat#") floatPrimTy +primOpInfo FloatNeOp = mkCompare SLIT("neFloat#") floatPrimTy +primOpInfo FloatLtOp = mkCompare SLIT("ltFloat#") floatPrimTy +primOpInfo FloatLeOp = mkCompare SLIT("leFloat#") floatPrimTy + +primOpInfo DoubleGtOp = mkCompare SLIT(">##") doublePrimTy +primOpInfo DoubleGeOp = mkCompare SLIT(">=##") doublePrimTy +primOpInfo DoubleEqOp = mkCompare SLIT("==##") doublePrimTy +primOpInfo DoubleNeOp = mkCompare SLIT("/=##") doublePrimTy +primOpInfo DoubleLtOp = mkCompare SLIT("<##") doublePrimTy +primOpInfo DoubleLeOp = mkCompare SLIT("<=##") doublePrimTy + \end{code} %************************************************************************ @@ -761,8 +961,8 @@ primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy %************************************************************************ \begin{code} -primOpInfo OrdOp = Coercing SLIT("ord#") charPrimTy intPrimTy -primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy +primOpInfo OrdOp = mkGenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy +primOpInfo ChrOp = mkGenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy \end{code} %************************************************************************ @@ -772,14 +972,14 @@ primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy %************************************************************************ \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 IntAddOp = mkDyadic SLIT("+#") intPrimTy +primOpInfo IntSubOp = mkDyadic SLIT("-#") intPrimTy +primOpInfo IntMulOp = mkDyadic SLIT("*#") intPrimTy +primOpInfo IntQuotOp = mkDyadic SLIT("quotInt#") intPrimTy +primOpInfo IntRemOp = mkDyadic SLIT("remInt#") intPrimTy + +primOpInfo IntNegOp = mkMonadic SLIT("negateInt#") intPrimTy +primOpInfo IntAbsOp = mkMonadic SLIT("absInt#") intPrimTy \end{code} %************************************************************************ @@ -791,27 +991,28 @@ primOpInfo IntAbsOp = Monadic SLIT("absInt#") intPrimTy A @Word#@ is an unsigned @Int#@. \begin{code} -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 WordQuotOp = mkDyadic SLIT("quotWord#") wordPrimTy +primOpInfo WordRemOp = mkDyadic SLIT("remWord#") wordPrimTy + +primOpInfo AndOp = mkDyadic SLIT("and#") wordPrimTy +primOpInfo OrOp = mkDyadic SLIT("or#") wordPrimTy +primOpInfo XorOp = mkDyadic SLIT("xor#") wordPrimTy +primOpInfo NotOp = mkMonadic SLIT("not#") wordPrimTy primOpInfo SllOp - = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep [] -primOpInfo SraOp - = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep [] + = mkGenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy primOpInfo SrlOp - = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep [] + = mkGenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy primOpInfo ISllOp - = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy primOpInfo ISraOp - = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy primOpInfo ISrlOp - = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy -primOpInfo Int2WordOp = Coercing SLIT("int2Word#") intPrimTy wordPrimTy -primOpInfo Word2IntOp = Coercing SLIT("word2Int#") wordPrimTy intPrimTy +primOpInfo Int2WordOp = mkGenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy +primOpInfo Word2IntOp = mkGenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy \end{code} %************************************************************************ @@ -821,10 +1022,11 @@ primOpInfo Word2IntOp = Coercing SLIT("word2Int#") wordPrimTy intPrimTy %************************************************************************ \begin{code} -primOpInfo Int2AddrOp = Coercing SLIT("int2Addr#") intPrimTy addrPrimTy -primOpInfo Addr2IntOp = Coercing SLIT("addr2Int#") addrPrimTy intPrimTy +primOpInfo Int2AddrOp = mkGenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy +primOpInfo Addr2IntOp = mkGenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy \end{code} + %************************************************************************ %* * \subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s} @@ -835,28 +1037,28 @@ primOpInfo Addr2IntOp = Coercing SLIT("addr2Int#") addrPrimTy intPrimTy 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 = Coercing SLIT("float2Int#") floatPrimTy intPrimTy -primOpInfo Int2FloatOp = Coercing 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 +primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy +primOpInfo FloatSubOp = mkDyadic SLIT("minusFloat#") floatPrimTy +primOpInfo FloatMulOp = mkDyadic SLIT("timesFloat#") floatPrimTy +primOpInfo FloatDivOp = mkDyadic SLIT("divideFloat#") floatPrimTy +primOpInfo FloatNegOp = mkMonadic SLIT("negateFloat#") floatPrimTy + +primOpInfo Float2IntOp = mkGenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy +primOpInfo Int2FloatOp = mkGenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy + +primOpInfo FloatExpOp = mkMonadic SLIT("expFloat#") floatPrimTy +primOpInfo FloatLogOp = mkMonadic SLIT("logFloat#") floatPrimTy +primOpInfo FloatSqrtOp = mkMonadic SLIT("sqrtFloat#") floatPrimTy +primOpInfo FloatSinOp = mkMonadic SLIT("sinFloat#") floatPrimTy +primOpInfo FloatCosOp = mkMonadic SLIT("cosFloat#") floatPrimTy +primOpInfo FloatTanOp = mkMonadic SLIT("tanFloat#") floatPrimTy +primOpInfo FloatAsinOp = mkMonadic SLIT("asinFloat#") floatPrimTy +primOpInfo FloatAcosOp = mkMonadic SLIT("acosFloat#") floatPrimTy +primOpInfo FloatAtanOp = mkMonadic SLIT("atanFloat#") floatPrimTy +primOpInfo FloatSinhOp = mkMonadic SLIT("sinhFloat#") floatPrimTy +primOpInfo FloatCoshOp = mkMonadic SLIT("coshFloat#") floatPrimTy +primOpInfo FloatTanhOp = mkMonadic SLIT("tanhFloat#") floatPrimTy +primOpInfo FloatPowerOp = mkDyadic SLIT("powerFloat#") floatPrimTy \end{code} %************************************************************************ @@ -869,31 +1071,31 @@ primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy 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 = Coercing SLIT("double2Int#") doublePrimTy intPrimTy -primOpInfo Int2DoubleOp = Coercing SLIT("int2Double#") intPrimTy 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 -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 +primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy +primOpInfo DoubleSubOp = mkDyadic SLIT("-##") doublePrimTy +primOpInfo DoubleMulOp = mkDyadic SLIT("*##") doublePrimTy +primOpInfo DoubleDivOp = mkDyadic SLIT("/##") doublePrimTy +primOpInfo DoubleNegOp = mkMonadic SLIT("negateDouble#") doublePrimTy + +primOpInfo Double2IntOp = mkGenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy +primOpInfo Int2DoubleOp = mkGenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy + +primOpInfo Double2FloatOp = mkGenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy +primOpInfo Float2DoubleOp = mkGenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy + +primOpInfo DoubleExpOp = mkMonadic SLIT("expDouble#") doublePrimTy +primOpInfo DoubleLogOp = mkMonadic SLIT("logDouble#") doublePrimTy +primOpInfo DoubleSqrtOp = mkMonadic SLIT("sqrtDouble#") doublePrimTy +primOpInfo DoubleSinOp = mkMonadic SLIT("sinDouble#") doublePrimTy +primOpInfo DoubleCosOp = mkMonadic SLIT("cosDouble#") doublePrimTy +primOpInfo DoubleTanOp = mkMonadic SLIT("tanDouble#") doublePrimTy +primOpInfo DoubleAsinOp = mkMonadic SLIT("asinDouble#") doublePrimTy +primOpInfo DoubleAcosOp = mkMonadic SLIT("acosDouble#") doublePrimTy +primOpInfo DoubleAtanOp = mkMonadic SLIT("atanDouble#") doublePrimTy +primOpInfo DoubleSinhOp = mkMonadic SLIT("sinhDouble#") doublePrimTy +primOpInfo DoubleCoshOp = mkMonadic SLIT("coshDouble#") doublePrimTy +primOpInfo DoubleTanhOp = mkMonadic SLIT("tanhDouble#") doublePrimTy +primOpInfo DoublePowerOp= mkDyadic SLIT("**##") doublePrimTy \end{code} %************************************************************************ @@ -908,6 +1110,7 @@ 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#") @@ -915,16 +1118,36 @@ primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#") primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#") primOpInfo Integer2IntOp - = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy + +primOpInfo Integer2WordOp + = mkGenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy primOpInfo Int2IntegerOp - = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon [] + = mkGenPrimOp SLIT("int2Integer#") [] [intPrimTy] + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) primOpInfo Word2IntegerOp - = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon [] + = mkGenPrimOp SLIT("word2Integer#") [] [wordPrimTy] + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) primOpInfo Addr2IntegerOp - = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon [] + = mkGenPrimOp SLIT("addr2Integer#") [] [addrPrimTy] + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) + +primOpInfo IntegerToInt64Op + = mkGenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy + +primOpInfo Int64ToIntegerOp + = mkGenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy] + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) + +primOpInfo Word64ToIntegerOp + = mkGenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy] + (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy]) + +primOpInfo IntegerToWord64Op + = mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy \end{code} Encoding and decoding of floating-point numbers is sorta @@ -932,18 +1155,17 @@ Integer-related. \begin{code} primOpInfo FloatEncodeOp - = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys - floatPrimTyCon FloatRep [] + = mkGenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy primOpInfo DoubleEncodeOp - = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys - doublePrimTyCon DoubleRep [] + = mkGenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy primOpInfo FloatDecodeOp - = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon [] - + = mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy] + (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy]) primOpInfo DoubleDecodeOp - = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon [] + = mkGenPrimOp SLIT("decodeDouble#") [] [doublePrimTy] + (unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy]) \end{code} %************************************************************************ @@ -955,22 +1177,23 @@ primOpInfo DoubleDecodeOp \begin{code} primOpInfo NewArrayOp = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s } in - AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s] - stateAndMutableArrayPrimTyCon [s, elt] + mkGenPrimOp SLIT("newArray#") [s_tv, elt_tv] + [intPrimTy, elt, state] + (unboxedPair [state, mkMutableArrayPrimTy s elt]) primOpInfo (NewByteArrayOp kind) = let s = alphaTy; s_tv = alphaTyVar - (str, _, prim_tycon) = getPrimRepInfo kind - - op_str = _PK_ ("new" ++ str ++ "Array#") + op_str = _PK_ ("new" ++ primRepString kind ++ "Array#") + state = mkStatePrimTy s in - AlgResult op_str [s_tv] - [intPrimTy, mkStatePrimTy s] - stateAndMutableByteArrayPrimTyCon [s] + mkGenPrimOp op_str [s_tv] + [intPrimTy, state] + (unboxedPair [state, mkMutableByteArrayPrimTy s]) --------------------------------------------------------------------------- @@ -979,41 +1202,42 @@ primOpInfo SameMutableArrayOp elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; mut_arr_ty = mkMutableArrayPrimTy s elt } in - AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty] - boolTyCon [] + mkGenPrimOp 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 - AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty] - boolTyCon [] + mkGenPrimOp 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 + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s } in - AlgResult SLIT("readArray#") [s_tv, elt_tv] - [mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s] - stateAndPtrPrimTyCon [s, elt] + mkGenPrimOp 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 - PrimResult SLIT("writeArray#") [s_tv, elt_tv] + mkGenPrimOp SLIT("writeArray#") [s_tv, elt_tv] [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s] - statePrimTyCon VoidRep [s] + (mkStatePrimTy s) primOpInfo IndexArrayOp = let { elt = alphaTy; elt_tv = alphaTyVar } in - AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] - liftTyCon [elt] + mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] + (unboxedPair [realWorldStatePrimTy, elt]) --------------------------------------------------------------------------- -- Primitive arrays full of unboxed bytes: @@ -1022,118 +1246,205 @@ primOpInfo (ReadByteArrayOp kind) = let s = alphaTy; s_tv = alphaTyVar - (str, _, prim_tycon) = getPrimRepInfo kind - - op_str = _PK_ ("read" ++ str ++ "Array#") - relevant_tycon = assoc "primOpInfo" tbl kind + op_str = _PK_ ("read" ++ primRepString kind ++ "Array#") + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind + state = mkStatePrimTy s in - AlgResult op_str [s_tv] - [mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s] - relevant_tycon [s] - where - tbl = [ (CharRep, stateAndCharPrimTyCon), - (IntRep, stateAndIntPrimTyCon), - (AddrRep, stateAndAddrPrimTyCon), - (FloatRep, stateAndFloatPrimTyCon), - (DoubleRep, stateAndDoublePrimTyCon) ] - - -- How come there's no Word byte arrays? ADR + mkGenPrimOp op_str (s_tv:tvs) + [mkMutableByteArrayPrimTy s, intPrimTy, state] + (unboxedPair [state, prim_ty]) primOpInfo (WriteByteArrayOp kind) = let s = alphaTy; s_tv = alphaTyVar - - (str, prim_ty, _) = getPrimRepInfo kind - op_str = _PK_ ("write" ++ str ++ "Array#") + op_str = _PK_ ("write" ++ primRepString kind ++ "Array#") + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind in - -- NB: *Prim*Result -- - PrimResult op_str [s_tv] + mkGenPrimOp op_str (s_tv:tvs) [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s] - statePrimTyCon VoidRep [s] + (mkStatePrimTy s) primOpInfo (IndexByteArrayOp kind) = let - (str, _, prim_tycon) = getPrimRepInfo kind - op_str = _PK_ ("index" ++ str ++ "Array#") + op_str = _PK_ ("index" ++ primRepString kind ++ "Array#") + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind + in + mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] prim_ty + +primOpInfo (IndexOffForeignObjOp kind) + = let + op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#") + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind in - -- NB: *Prim*Result -- - PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind [] + mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] prim_ty primOpInfo (IndexOffAddrOp kind) = let - (str, _, prim_tycon) = getPrimRepInfo kind - op_str = _PK_ ("index" ++ str ++ "OffAddr#") + op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#") + (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind in - PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind [] + mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] prim_ty -primOpInfo (IndexOffForeignObjOp kind) +primOpInfo (WriteOffAddrOp kind) = let - (str, _, prim_tycon) = getPrimRepInfo kind - op_str = _PK_ ("index" ++ str ++ "OffForeignObj#") + s = alphaTy; s_tv = alphaTyVar + op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#") + (tvs, prim_ty) = mkPrimTyApp betaTyVars kind in - PrimResult op_str [] [foreignObjPrimTy, intPrimTy] prim_tycon kind [] + mkGenPrimOp op_str (s_tv:tvs) + [addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s] + (mkStatePrimTy s) --------------------------------------------------------------------------- primOpInfo UnsafeFreezeArrayOp = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s } in - AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv] - [mkMutableArrayPrimTy s elt, mkStatePrimTy s] - stateAndArrayPrimTyCon [s, elt] + mkGenPrimOp 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 + mkGenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv] + [mkMutableByteArrayPrimTy s, state] + (unboxedPair [state, byteArrayPrimTy]) + +--------------------------------------------------------------------------- +primOpInfo SizeofByteArrayOp + = mkGenPrimOp + SLIT("sizeofByteArray#") [] + [byteArrayPrimTy] + intPrimTy + +primOpInfo SizeofMutableByteArrayOp = let { s = alphaTy; s_tv = alphaTyVar } in - AlgResult SLIT("unsafeFreezeByteArray#") [s_tv] - [mkMutableByteArrayPrimTy s, mkStatePrimTy s] - stateAndByteArrayPrimTyCon [s] + mkGenPrimOp + SLIT("sizeofMutableByteArray#") [s_tv] + [mkMutableByteArrayPrimTy s] + intPrimTy \end{code} + %************************************************************************ %* * -\subsubsection[PrimOp-SynchVars]{PrimOpInfo for synchronizing Variables} +\subsubsection[PrimOp-MutVars]{PrimOpInfo for mutable variable ops} %* * %************************************************************************ \begin{code} -primOpInfo NewSynchVarOp +primOpInfo NewMutVarOp = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s } in - AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s] - stateAndSynchVarPrimTyCon [s, elt] + mkGenPrimOp SLIT("newMutVar#") [s_tv, elt_tv] + [elt, state] + (unboxedPair [state, mkMutVarPrimTy s elt]) -primOpInfo TakeMVarOp +primOpInfo ReadMutVarOp = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + state = mkStatePrimTy s } in - AlgResult SLIT("takeMVar#") [s_tv, elt_tv] - [mkSynchVarPrimTy s elt, mkStatePrimTy s] - stateAndPtrPrimTyCon [s, elt] + mkGenPrimOp SLIT("readMutVar#") [s_tv, elt_tv] + [mkMutVarPrimTy s elt, state] + (unboxedPair [state, elt]) -primOpInfo PutMVarOp + +primOpInfo WriteMutVarOp = let { elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar } in - AlgResult SLIT("putMVar#") [s_tv, elt_tv] - [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s] - statePrimTyCon [s] + mkGenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv] + [mkMutVarPrimTy s elt, elt, mkStatePrimTy s] + (mkStatePrimTy s) -primOpInfo ReadIVarOp +primOpInfo SameMutVarOp = let { - elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar; + mut_var_ty = mkMutVarPrimTy s elt } in - AlgResult SLIT("readIVar#") [s_tv, elt_tv] - [mkSynchVarPrimTy s elt, mkStatePrimTy s] - stateAndPtrPrimTyCon [s, elt] + mkGenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty] + boolTy +\end{code} -primOpInfo WriteIVarOp - = let { +%************************************************************************ +%* * +\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 + mkGenPrimOp 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 + mkGenPrimOp 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 - } in - AlgResult SLIT("writeIVar#") [s_tv, elt_tv] - [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s] - statePrimTyCon [s] + state = mkStatePrimTy s + in + mkGenPrimOp 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 + mkGenPrimOp 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 + mkGenPrimOp 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 + mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy + +primOpInfo IsEmptyMVarOp + = let + elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar + state = mkStatePrimTy s + in + mkGenPrimOp SLIT("isEmptyMVar#") [s_tv, elt_tv] + [mkMVarPrimTy s elt, mkStatePrimTy s] + (unboxedPair [state, intPrimTy]) \end{code} @@ -1149,135 +1460,210 @@ primOpInfo DelayOp = let { s = alphaTy; s_tv = alphaTyVar } in - PrimResult SLIT("delay#") [s_tv] - [intPrimTy, mkStatePrimTy s] - statePrimTyCon VoidRep [s] + mkGenPrimOp SLIT("delay#") [s_tv] + [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) primOpInfo WaitReadOp = let { s = alphaTy; s_tv = alphaTyVar } in - PrimResult SLIT("waitRead#") [s_tv] - [intPrimTy, mkStatePrimTy s] - statePrimTyCon VoidRep [s] + mkGenPrimOp SLIT("waitRead#") [s_tv] + [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) primOpInfo WaitWriteOp = let { s = alphaTy; s_tv = alphaTyVar } in - PrimResult SLIT("waitWrite#") [s_tv] - [intPrimTy, mkStatePrimTy s] - statePrimTyCon VoidRep [s] + mkGenPrimOp SLIT("waitWrite#") [s_tv] + [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s) \end{code} %************************************************************************ %* * -\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects} +\subsubsection[PrimOp-Concurrency]{Concurrency Primitives} %* * %************************************************************************ -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. +\begin{code} +-- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) +primOpInfo ForkOp + = mkGenPrimOp SLIT("fork#") [alphaTyVar] + [alphaTy, realWorldStatePrimTy] + (unboxedPair [realWorldStatePrimTy, threadIdPrimTy]) -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 +-- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld +primOpInfo KillThreadOp + = mkGenPrimOp SLIT("killThread#") [] + [threadIdPrimTy, realWorldStatePrimTy] + realWorldStatePrimTy +\end{code} -A @ForeignObj@ is created by the @makeForeignObj#@ primitive: +************************************************************************ +%* * +\subsubsection[PrimOps-Foreign]{PrimOpInfo for Foreign Objects} +%* * +%************************************************************************ -\begin{pseudocode} -makeForeignObj# :: Addr# -- foreign object - -> Addr# -- ptr to its finaliser routine - -> StateAndForeignObj# _RealWorld# ForeignObj# -\end{pseudocode} +\begin{code} +primOpInfo MakeForeignObjOp + = mkGenPrimOp SLIT("makeForeignObj#") [] + [addrPrimTy, realWorldStatePrimTy] + (unboxedPair [realWorldStatePrimTy, foreignObjPrimTy]) +primOpInfo WriteForeignObjOp + = let { + s = alphaTy; s_tv = alphaTyVar + } in + mkGenPrimOp SLIT("writeForeignObj#") [s_tv] + [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s) +\end{code} + +************************************************************************ +%* * +\subsubsection[PrimOps-Weak]{PrimOpInfo for Weak Pointers} +%* * +%************************************************************************ + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) \begin{code} -primOpInfo MakeForeignObjOp - = AlgResult SLIT("makeForeignObj#") [] - [addrPrimTy, addrPrimTy, realWorldStatePrimTy] - stateAndForeignObjPrimTyCon [realWorldTy] +primOpInfo MkWeakOp + = mkGenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar] + [alphaTy, betaTy, gammaTy, realWorldStatePrimTy] + (unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy]) \end{code} -[Experimental--SOF] -In addition, another @ForeignObj@ primitive is provided for destructively modifying -the external object wrapped up inside a @ForeignObj@. This primitive is used -when a mixed programming interface of implicit and explicit de-allocation is used, -e.g., if @ForeignObj@s are used to implement @Handle@s, then @Handle@s can be -released either explicitly (through @hClose@) or implicitly (via a finaliser). -When releasing/closing the @Handle@ explicitly, care must be taken to avoid having -the finaliser for the embedded @ForeignObj@ attempt the same thing later. -We deal with this situation, by allowing the programmer to destructively modify -the data field of the @ForeignObj@ to hold a special value the finaliser recognises, -and does not attempt to free (e.g., filling the data slot with \tr{NULL}). +The following operation dereferences a weak pointer. The weak pointer +may have been finalised, so the operation returns a result code which +must be inspected before looking at the dereferenced value. -\begin{pseudocode} -writeForeignObj# :: ForeignObj# -- foreign object - -> Addr# -- new data value - -> StateAndForeignObj# _RealWorld# ForeignObj# -\end{pseudocode} + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) \begin{code} -primOpInfo WriteForeignObjOp - = let { - s = alphaTy; s_tv = alphaTyVar - } in - PrimResult SLIT("writeForeignObj#") [s_tv] - [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] - statePrimTyCon VoidRep [s] +primOpInfo DeRefWeakOp + = mkGenPrimOp SLIT("deRefWeak#") [alphaTyVar] + [mkWeakPrimTy alphaTy, realWorldStatePrimTy] + (unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy]) +\end{code} + +Weak pointers can be finalised early by using the finalise# operation: + + finalise# :: Weak# v -> State# RealWorld -> State# RealWorld + +\begin{code} +primOpInfo FinaliseWeakOp + = mkGenPrimOp SLIT("finaliseWeak#") [alphaTyVar] + [mkWeakPrimTy alphaTy, realWorldStatePrimTy] + realWorldStatePrimTy \end{code} %************************************************************************ %* * -\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''} +\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for stable pointers and stable names} %* * %************************************************************************ -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 +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. -Here's what the operations and types are supposed to be (from -state-interface document). - \begin{verbatim} -makeStablePtr# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a -freeStablePtr# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld -deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, 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] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (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' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. \begin{code} primOpInfo MakeStablePtrOp - = AlgResult SLIT("makeStablePtr#") [alphaTyVar] + = mkGenPrimOp SLIT("makeStablePtr#") [alphaTyVar] [alphaTy, realWorldStatePrimTy] - stateAndStablePtrPrimTyCon [realWorldTy, alphaTy] + (unboxedPair [realWorldStatePrimTy, + mkTyConApp stablePtrPrimTyCon [alphaTy]]) primOpInfo DeRefStablePtrOp - = AlgResult SLIT("deRefStablePtr#") [alphaTyVar] + = mkGenPrimOp SLIT("deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy] - stateAndPtrPrimTyCon [realWorldTy, alphaTy] + (unboxedPair [realWorldStatePrimTy, alphaTy]) + +primOpInfo EqStablePtrOp + = mkGenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar] + [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy] + intPrimTy + +primOpInfo MakeStableNameOp + = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar] + [alphaTy, realWorldStatePrimTy] + (unboxedPair [realWorldStatePrimTy, + mkTyConApp stableNamePrimTyCon [alphaTy]]) + +primOpInfo EqStableNameOp + = mkGenPrimOp SLIT("eqStableName#") [alphaTyVar, betaTyVar] + [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] + intPrimTy + +primOpInfo StableNameToIntOp + = mkGenPrimOp SLIT("stableNameToInt#") [alphaTyVar] + [mkStableNamePrimTy alphaTy] + intPrimTy \end{code} %************************************************************************ @@ -1321,8 +1707,8 @@ removed...) \begin{code} primOpInfo ReallyUnsafePtrEqualityOp - = PrimResult SLIT("reallyUnsafePtrEquality#") [alphaTyVar] - [alphaTy, alphaTy] intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar] + [alphaTy, alphaTy] intPrimTy \end{code} %************************************************************************ @@ -1333,14 +1719,10 @@ primOpInfo ReallyUnsafePtrEqualityOp \begin{code} primOpInfo SeqOp -- seq# :: a -> Int# - = PrimResult SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] + = mkGenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy primOpInfo ParOp -- par# :: a -> Int# - = PrimResult SLIT("par#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] - -primOpInfo ForkOp -- fork# :: a -> Int# - = PrimResult SLIT("fork#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] - + = mkGenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy \end{code} \begin{code} @@ -1349,42 +1731,28 @@ primOpInfo ForkOp -- fork# :: a -> Int# -- 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] + = mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy 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] + = mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy 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] + = mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy 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] + = mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy 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] + = mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy 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] + = mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy primOpInfo CopyableOp -- copyable# :: a -> a - = PrimResult SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy] + = mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy primOpInfo NoFollowOp -- noFollow# :: a -> a - = PrimResult SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy] -\end{code} - -%************************************************************************ -%* * -\subsubsection[PrimOp-errorIO]{PrimOpInfo for @errorIO#@} -%* * -%************************************************************************ - -\begin{code} --- errorIO# :: (State# RealWorld# -> a) -> State# RealWorld# -primOpInfo ErrorIOPrimOp - = PrimResult SLIT("errorIO#") [alphaTyVar] - [mkFunTy realWorldStatePrimTy alphaTy] - statePrimTyCon VoidRep [realWorldTy] + = mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy \end{code} %************************************************************************ @@ -1394,144 +1762,58 @@ primOpInfo ErrorIOPrimOp %************************************************************************ \begin{code} -primOpInfo (CCallOp _ _ _ arg_tys result_ty) - = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied - where - (result_tycon, tys_applied, _) = getAppDataTyConExpandingDicts result_ty +primOpInfo (CCallOp _ _ _ _) + = mkGenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy +{- +primOpInfo (CCallOp _ _ _ _ arg_tys result_ty) + = mkGenPrimOp 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} -%************************************************************************ -%* * -\subsection[PrimOp-utils]{Utilities for @PrimitiveOps@} -%* * -%************************************************************************ - -The primitive-array-creation @PrimOps@ and {\em most} of those to do -with @Integers@ can trigger GC. Here we describe the heap requirements -of the various @PrimOps@. For most, no heap is required. For a few, -a fixed amount of heap is required, and the needs of the @PrimOp@ can -be combined with the rest of the heap usage in the basic block. For an -unfortunate few, some unknown amount of heap is required (these are the -ops which can trigger GC). - -\begin{code} -data HeapRequirement - = NoHeapRequired - | FixedHeapRequired HeapOffset - | VariableHeapRequired - -primOpHeapReq :: PrimOp -> HeapRequirement - -primOpHeapReq NewArrayOp = VariableHeapRequired -primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired - -primOpHeapReq IntegerAddOp = VariableHeapRequired -primOpHeapReq IntegerSubOp = VariableHeapRequired -primOpHeapReq IntegerMulOp = VariableHeapRequired -primOpHeapReq IntegerQuotRemOp = VariableHeapRequired -primOpHeapReq IntegerDivModOp = VariableHeapRequired -primOpHeapReq IntegerNegOp = VariableHeapRequired -primOpHeapReq Int2IntegerOp = FixedHeapRequired - (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) - (intOff mIN_MP_INT_SIZE)) -primOpHeapReq Word2IntegerOp = FixedHeapRequired - (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) - (intOff mIN_MP_INT_SIZE)) -primOpHeapReq Addr2IntegerOp = VariableHeapRequired -primOpHeapReq FloatDecodeOp = FixedHeapRequired - (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE)) - (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) - (intOff mIN_MP_INT_SIZE))) -primOpHeapReq DoubleDecodeOp = FixedHeapRequired - (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE)) - (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) - (intOff mIN_MP_INT_SIZE))) - -{- - ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) - or if it returns a ForeignObj. - - Hmm..the allocation for makeForeignObj# is known (and fixed), so - why dod we need to be so indeterminate about it? --SOF --} -primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired -primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired - -primOpHeapReq MakeForeignObjOp = VariableHeapRequired -primOpHeapReq WriteForeignObjOp = NoHeapRequired - --- this occasionally has to expand the Stable Pointer table -primOpHeapReq MakeStablePtrOp = VariableHeapRequired - --- These four only need heap space with the native code generator --- ToDo!: parameterize, so we know if native code generation is taking place(JSM) - -primOpHeapReq IntegerCmpOp = FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE)) -primOpHeapReq Integer2IntOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) -primOpHeapReq FloatEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) -primOpHeapReq DoubleEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) - --- a NewSynchVarOp creates a three-word mutuple in the heap. -primOpHeapReq NewSynchVarOp = FixedHeapRequired - (addOff (totHdrSize (MuTupleRep 3)) (intOff 3)) - --- Sparking ops no longer allocate any heap; however, _fork_ may --- require a context switch to clear space in the required thread --- pool, and that requires liveness information. - -primOpHeapReq ParOp = NoHeapRequired -primOpHeapReq ForkOp = VariableHeapRequired - --- A SeqOp requires unknown space to evaluate its argument -primOpHeapReq SeqOp = VariableHeapRequired - --- 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 - -primOpHeapReq other_op = NoHeapRequired -\end{code} - -The amount of stack required by primops. - -\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. -In particular, their arguments are guaranteed to be in registers, -and a liveness mask tells which regs are live. +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. \begin{code} -primOpCanTriggerGC op +primOpOutOfLine op = case op of - TakeMVarOp -> True - ReadIVarOp -> True - DelayOp -> True - WaitReadOp -> True - WaitWriteOp -> True - _ -> - case primOpHeapReq op of - VariableHeapRequired -> True - _ -> False + 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 + FinaliseWeakOp -> True + MakeStableNameOp -> True + MakeForeignObjOp -> True + NewMutVarOp -> True + NewMVarOp -> True + ForkOp -> True + KillThreadOp -> True + CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_ + _ -> False \end{code} Sometimes we may choose to execute a PrimOp even though it isn't @@ -1542,112 +1824,101 @@ this is OK, because PrimOps are usually cheap, but it isn't OK for See also @primOpIsCheap@ (below). -There should be no worries about side effects; that's all taken care -of by data dependencies. +PrimOps that have side effects also should not be executed speculatively +or by data dependencies. \begin{code} primOpOkForSpeculation :: PrimOp -> Bool +primOpOkForSpeculation op + = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op) +\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. "Cheap" means willing to call it more +than once. Evaluation order is unaffected. + +\begin{code} +primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op) +\end{code} + +\begin{code} +primOpCanFail :: PrimOp -> Bool -- Int. -primOpOkForSpeculation IntQuotOp = False -- Divide by zero -primOpOkForSpeculation IntRemOp = False -- Divide by zero +primOpCanFail IntQuotOp = True -- Divide by zero +primOpCanFail IntRemOp = True -- Divide by zero -- Integer -primOpOkForSpeculation IntegerQuotRemOp = False -- Divide by zero -primOpOkForSpeculation IntegerDivModOp = False -- Divide by zero +primOpCanFail IntegerQuotRemOp = True -- Divide by zero +primOpCanFail IntegerDivModOp = True -- Divide by zero -- Float. ToDo: tan? tanh? -primOpOkForSpeculation FloatDivOp = False -- Divide by zero -primOpOkForSpeculation FloatLogOp = False -- Log of zero -primOpOkForSpeculation FloatAsinOp = False -- Arg out of domain -primOpOkForSpeculation FloatAcosOp = False -- Arg out of domain +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? -primOpOkForSpeculation DoubleDivOp = False -- Divide by zero -primOpOkForSpeculation DoubleLogOp = False -- Log of zero -primOpOkForSpeculation DoubleAsinOp = False -- Arg out of domain -primOpOkForSpeculation DoubleAcosOp = False -- Arg out of domain +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 --- CCall -primOpOkForSpeculation (CCallOp _ _ _ _ _)= False -- Could be expensive! - --- errorIO# -primOpOkForSpeculation ErrorIOPrimOp = False -- Could be disastrous! - --- parallel -primOpOkForSpeculation ParOp = False -- Could be expensive! -primOpOkForSpeculation ForkOp = False -- Likewise -primOpOkForSpeculation SeqOp = False -- Likewise - -primOpOkForSpeculation ParGlobalOp = False -- Could be expensive! -primOpOkForSpeculation ParLocalOp = False -- Could be expensive! -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} -primOpIsCheap op - = primOpOkForSpeculation op && not (primOpCanTriggerGC op) +primOpCanFail other_op = False \end{code} And some primops have side-effects and so, for example, must not be duplicated. \begin{code} -fragilePrimOp :: PrimOp -> Bool - -fragilePrimOp ParOp = True -fragilePrimOp ForkOp = True -fragilePrimOp SeqOp = True -fragilePrimOp MakeForeignObjOp = True -- SOF -fragilePrimOp WriteForeignObjOp = True -- SOF -fragilePrimOp MakeStablePtrOp = True -fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR - -fragilePrimOp ParGlobalOp = True -fragilePrimOp ParLocalOp = True -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 +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 FinaliseWeakOp = True +primOpHasSideEffects MakeStablePtrOp = True +primOpHasSideEffects MakeStableNameOp = 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 \end{code} -Primitive operations that perform calls need wrappers to save any live variables -that are stored in caller-saves registers +Inline primitive operations that perform calls need wrappers to save +any live variables that are stored in caller-saves registers. \begin{code} primOpNeedsWrapper :: PrimOp -> Bool -primOpNeedsWrapper (CCallOp _ _ _ _ _) = True - -primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM) -primOpNeedsWrapper (NewByteArrayOp _) = True +primOpNeedsWrapper (CCallOp _ _ _ _) = True -primOpNeedsWrapper IntegerAddOp = True -primOpNeedsWrapper IntegerSubOp = True -primOpNeedsWrapper IntegerMulOp = True -primOpNeedsWrapper IntegerQuotRemOp = True -primOpNeedsWrapper IntegerDivModOp = True -primOpNeedsWrapper IntegerNegOp = True -primOpNeedsWrapper IntegerCmpOp = True primOpNeedsWrapper Integer2IntOp = True -primOpNeedsWrapper Int2IntegerOp = True -primOpNeedsWrapper Word2IntegerOp = True -primOpNeedsWrapper Addr2IntegerOp = True +primOpNeedsWrapper Integer2WordOp = True +primOpNeedsWrapper IntegerCmpOp = True primOpNeedsWrapper FloatExpOp = True primOpNeedsWrapper FloatLogOp = True @@ -1662,8 +1933,7 @@ primOpNeedsWrapper FloatSinhOp = True primOpNeedsWrapper FloatCoshOp = True primOpNeedsWrapper FloatTanhOp = True primOpNeedsWrapper FloatPowerOp = True -primOpNeedsWrapper FloatEncodeOp = True -primOpNeedsWrapper FloatDecodeOp = True +primOpNeedsWrapper FloatEncodeOp = True primOpNeedsWrapper DoubleExpOp = True primOpNeedsWrapper DoubleLogOp = True @@ -1678,18 +1948,11 @@ primOpNeedsWrapper DoubleSinhOp = True primOpNeedsWrapper DoubleCoshOp = True primOpNeedsWrapper DoubleTanhOp = True primOpNeedsWrapper DoublePowerOp = True -primOpNeedsWrapper DoubleEncodeOp = True -primOpNeedsWrapper DoubleDecodeOp = True +primOpNeedsWrapper DoubleEncodeOp = True -primOpNeedsWrapper MakeForeignObjOp = True -primOpNeedsWrapper WriteForeignObjOp = True -primOpNeedsWrapper MakeStablePtrOp = True +primOpNeedsWrapper MakeStableNameOp = True primOpNeedsWrapper DeRefStablePtrOp = True -primOpNeedsWrapper TakeMVarOp = True -primOpNeedsWrapper PutMVarOp = True -primOpNeedsWrapper ReadIVarOp = True - primOpNeedsWrapper DelayOp = True primOpNeedsWrapper WaitReadOp = True primOpNeedsWrapper WaitWriteOp = True @@ -1698,33 +1961,27 @@ primOpNeedsWrapper other_op = False \end{code} \begin{code} -primOp_str op +primOpOcc op = case (primOpInfo op) of - Dyadic str _ -> str - Monadic str _ -> str - Compare str _ -> str - Coercing str _ _ -> str - PrimResult str _ _ _ _ _ -> str - AlgResult str _ _ _ _ -> str + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ \end{code} -@primOpType@ duplicates some work of @primOpId@, but since we -grab types pretty often... \begin{code} -primOpType :: PrimOp -> Type +primOpUniq :: PrimOp -> Unique +primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op)) +primOpType :: PrimOp -> Type 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 - Coercing str ty1 ty2 -> mkFunTy ty1 ty2 - - PrimResult str tyvars arg_tys prim_tycon kind res_tys -> - mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)) + Dyadic occ ty -> dyadic_fun_ty ty + Monadic occ ty -> monadic_fun_ty ty + Compare occ ty -> compare_fun_ty ty - AlgResult str tyvars arg_tys tycon res_tys -> - mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)) + GenPrimOp occ tyvars arg_tys res_ty -> + mkForAllTys tyvars (mkFunTys arg_tys res_ty) \end{code} \begin{code} @@ -1732,8 +1989,9 @@ data PrimOpResultInfo = ReturnsPrim PrimRep | ReturnsAlg TyCon --- ToDo: Deal with specialised PrimOps --- Will need to return specialised tycon and data constructors +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo @@ -1742,9 +2000,13 @@ getPrimOpResultInfo op Dyadic _ ty -> ReturnsPrim (typePrimRep ty) Monadic _ ty -> ReturnsPrim (typePrimRep ty) Compare _ ty -> ReturnsAlg boolTyCon - Coercing _ _ ty -> ReturnsPrim (typePrimRep ty) - PrimResult _ _ _ _ kind _ -> ReturnsPrim kind - AlgResult _ _ _ tycon _ -> ReturnsAlg tycon + 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 @@ -1771,6 +2033,7 @@ commutableOp IntEqOp = True commutableOp IntNeOp = True commutableOp IntegerAddOp = True commutableOp IntegerMulOp = True +commutableOp IntegerGcdOp = True commutableOp FloatAddOp = True commutableOp FloatMulOp = True commutableOp FloatEqOp = True @@ -1784,6 +2047,15 @@ commutableOp _ = False Utils: \begin{code} +mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type) + -- CharRep --> ([], Char#) + -- StablePtrRep --> ([a], StablePtr# a) +mkPrimTyApp tvs kind + = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs)) + where + tycon = primRepTyCon kind + forall_tvs = take (tyConArity tycon) tvs + dyadic_fun_ty ty = mkFunTys [ty, ty] ty monadic_fun_ty ty = mkFunTy ty ty compare_fun_ty ty = mkFunTys [ty, ty] boolTy @@ -1791,41 +2063,43 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} -pprPrimOp :: PprStyle -> PrimOp -> Doc -showPrimOp :: PprStyle -> PrimOp -> String +pprPrimOp :: PrimOp -> SDoc -showPrimOp sty op = render (pprPrimOp sty op) - -pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) +pprPrimOp (CCallOp fun is_casm may_gc cconv) = let + callconv = text "{-" <> pprCallConv cconv <> text "-}" + before - = if is_casm then - if may_gc then "_casm_GC_ ``" else "_casm_ ``" - else - if may_gc then "_ccall_GC_ " else "_ccall_ " + | is_casm && may_gc = "casm_GC ``" + | is_casm = "casm ``" + | may_gc = "ccall_GC " + | otherwise = "ccall " after - = if is_casm then text "''" else empty - - pp_tys - = hsep (map (pprParendGenType sty) (res_ty:arg_tys)) + | is_casm = text "''" + | otherwise = empty + + ppr_dyn = + case fun of + Right _ -> text "dyn_" + _ -> empty + + ppr_fun = + case fun of + Right _ -> text "\"\"" + Left fn -> ptext fn + in - hcat [text before, ptext fun, after, space, brackets pp_tys] - -pprPrimOp sty other_op - | codeStyle sty -- For C just print the primop itself - = identToC str - - | ifaceStyle sty -- For interfaces Print it qualified with GHC. - = ptext SLIT("GHC.") <> ptext str - - | otherwise -- Unqualified is good enough - = ptext str + hcat [ ifPprDebug callconv + , text "__", ppr_dyn + , text before , ppr_fun , after] + +pprPrimOp other_op + = getPprStyle $ \ sty -> + if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC. + ptext SLIT("PrelGHC.") <> pprOccName occ + else + pprOccName occ where - str = primOp_str other_op - - - -instance Outputable PrimOp where - ppr sty op = pprPrimOp sty op + occ = primOpOcc other_op \end{code}