ghc/compiler/prelude/PrimOps.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[PrimOps]{Primitive operations (machine-level)}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module PrimOps (
  10         PrimOp(..),
  11         tagOf_PrimOp, -- ToDo: rm
  12         primOpNameInfo, primOpId,
  13         typeOfPrimOp, isCompareOp,
  14         primOpCanTriggerGC, primOpNeedsWrapper,
  15         primOpOkForSpeculation, primOpIsCheap,
  16         fragilePrimOp,
  17
  18         PrimOpResultInfo(..),
  19         getPrimOpResultInfo,
  20
  21         HeapRequirement(..), primOpHeapReq,
  22
  23        -- export for the Native Code Generator
  24 --      primOpInfo, not exported
  25         PrimOpInfo(..),
  26
  27         pprPrimOp, showPrimOp,
  28
  29         -- and to make the interface self-sufficient....
  30         PrimKind, HeapOffset, Id, Name, TyCon, UniType, TyVarTemplate
  31     ) where
  32
  33 import PrelFuns         -- help stuff for prelude
  34 import PrimKind         -- most of it
  35 import TysPrim
  36 import TysWiredIn
  37
  38 import AbsUniType       -- lots of things
  39 import CLabelInfo       ( identToC )
  40 import CgCompInfo       ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
  41 import BasicLit         ( BasicLit(..) )
  42 import HeapOffs         ( addOff, intOff, totHdrSize, HeapOffset )
  43 import Id               -- lots
  44 import IdInfo           -- plenty of this, too
  45 import Maybes           ( Maybe(..) )
  46 import NameTypes        ( mkPreludeCoreName, FullName, ShortName )
  47 import Outputable
  48 import PlainCore        -- all of it
  49 import Pretty
  50 import SMRep            ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
  51 import Unique
  52 import Util
  53 #ifdef DPH
  54 import TyPod
  55 #endif {- Data Parallel Haskell -}
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[PrimOps-datatype]{Datatype for @PrimOp@ (an enumeration)}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 These are in \tr{state-interface.verb} order.
  65
  66 \begin{code}
  67 data PrimOp
  68     -- dig the FORTRAN/C influence on the names...
  69
  70     -- comparisons:
  71
  72     = CharGtOp   | CharGeOp   | CharEqOp   | CharNeOp   | CharLtOp   | CharLeOp
  73     | IntGtOp    | IntGeOp    | IntEqOp    | IntNeOp    | IntLtOp    | IntLeOp
  74     | WordGtOp   | WordGeOp   | WordEqOp   | WordNeOp   | WordLtOp   | WordLeOp
  75     | AddrGtOp   | AddrGeOp   | AddrEqOp   | AddrNeOp   | AddrLtOp   | AddrLeOp
  76     | FloatGtOp  | FloatGeOp  | FloatEqOp  | FloatNeOp  | FloatLtOp  | FloatLeOp
  77     | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
  78
  79     -- Char#-related ops:
  80     | OrdOp | ChrOp
  81
  82     -- Int#-related ops:
  83     -- IntAbsOp unused?? ADR
  84     | IntAddOp | IntSubOp | IntMulOp | IntQuotOp
  85     | IntDivOp | IntRemOp | IntNegOp | IntAbsOp
  86
  87     -- Word#-related ops:
  88     | AndOp  | OrOp   | NotOp
  89     | SllOp  | SraOp  | SrlOp  -- shift {left,right} {arithmetic,logical}
  90     | ISllOp | ISraOp | ISrlOp -- equivs on Int#s
  91     | Int2WordOp | Word2IntOp -- casts
  92
  93     -- Addr#-related ops:
  94     | Int2AddrOp | Addr2IntOp -- casts
  95
  96     -- Float#-related ops:
  97     | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
  98     | Float2IntOp | Int2FloatOp
  99
 100     | FloatExpOp   | FloatLogOp   | FloatSqrtOp
 101     | FloatSinOp   | FloatCosOp   | FloatTanOp
 102     | FloatAsinOp  | FloatAcosOp  | FloatAtanOp
 103     | FloatSinhOp  | FloatCoshOp  | FloatTanhOp
 104     -- not all machines have these available conveniently:
 105     -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp
 106     | FloatPowerOp -- ** op
 107
 108     -- Double#-related ops:
 109     | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp
 110     | Double2IntOp | Int2DoubleOp
 111     | Double2FloatOp | Float2DoubleOp
 112
 113     | DoubleExpOp   | DoubleLogOp   | DoubleSqrtOp
 114     | DoubleSinOp   | DoubleCosOp   | DoubleTanOp
 115     | DoubleAsinOp  | DoubleAcosOp  | DoubleAtanOp
 116     | DoubleSinhOp  | DoubleCoshOp  | DoubleTanhOp
 117     -- not all machines have these available conveniently:
 118     -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp
 119     | DoublePowerOp -- ** op
 120
 121     -- Integer (and related...) ops:
 122     -- slightly weird -- to match GMP package.
 123     | IntegerAddOp | IntegerSubOp | IntegerMulOp
 124     | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
 125
 126     | IntegerCmpOp
 127
 128     | Integer2IntOp  | Int2IntegerOp
 129     | Word2IntegerOp
 130     | Addr2IntegerOp -- "Addr" is *always* a literal string
 131     -- ?? gcd, etc?
 132
 133     | FloatEncodeOp  | FloatDecodeOp
 134     | DoubleEncodeOp | DoubleDecodeOp
 135
 136     -- primitive ops for primitive arrays
 137
 138     | NewArrayOp
 139     | NewByteArrayOp PrimKind
 140
 141     | SameMutableArrayOp
 142     | SameMutableByteArrayOp
 143
 144     | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
 145
 146     | ReadByteArrayOp   PrimKind
 147     | WriteByteArrayOp  PrimKind
 148     | IndexByteArrayOp  PrimKind
 149     | IndexOffAddrOp    PrimKind
 150         -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
 151         -- This is just a cheesy encoding of a bunch of ops.
 152         -- Note that MallocPtrKind is not included -- the only way of
 153         -- creating a MallocPtr is with a ccall or casm.
 154
 155     | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
 156
 157     | NewSynchVarOp -- for MVars and IVars
 158     | TakeMVarOp | PutMVarOp
 159     | ReadIVarOp | WriteIVarOp
 160
 161     | MakeStablePtrOp | DeRefStablePtrOp
 162 \end{code}
 163
 164 A special ``trap-door'' to use in making calls direct to C functions:
 165 \begin{code}
 166     | CCallOp   FAST_STRING     -- An "unboxed" ccall# to this named function
 167                 Bool            -- True <=> really a "casm"
 168                 Bool            -- True <=> might invoke Haskell GC
 169                 [UniType]       -- Unboxed argument; the state-token
 170                                 -- argument will have been put *first*
 171                 UniType         -- Return type; one of the "StateAnd<blah>#" types
 172
 173     -- (... to be continued ... )
 174 \end{code}
 175
 176 The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@.
 177 (See @primOpInfo@ for details.)
 178
 179 Note: that first arg and part of the result should be the system state
 180 token (which we carry around to fool over-zealous optimisers) but
 181 which isn't actually passed.
 182
 183 For example, we represent
 184 \begin{pseudocode}
 185 ((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld)
 186 \end{pseudocode}
 187 by
 188 \begin{pseudocode}
 189 CoCase
 190   ( CoPrim
 191       (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
 192        -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
 193       []
 194       [w#, sp# i#]
 195   )
 196   (CoAlgAlts [ ( FloatPrimAndIoWorld,
 197                  [f#, w#],
 198                  CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
 199                ) ]
 200              CoNoDefault
 201   )
 202 \end{pseudocode}
 203
 204 Nota Bene: there are some people who find the empty list of types in
 205 the @CoPrim@ somewhat puzzling and would represent the above by
 206 \begin{pseudocode}
 207 CoCase
 208   ( CoPrim
 209       (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
 210        -- :: /\ alpha1, alpha2 alpha3, alpha4.
 211        --       alpha1 -> alpha2 -> alpha3 -> alpha4
 212       [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
 213       [w#, sp# i#]
 214   )
 215   (CoAlgAlts [ ( FloatPrimAndIoWorld,
 216                  [f#, w#],
 217                  CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
 218                ) ]
 219              CoNoDefault
 220   )
 221 \end{pseudocode}
 222
 223 But, this is a completely different way of using @CCallOp@.  The most
 224 major changes required if we switch to this are in @primOpInfo@, and
 225 the desugarer. The major difficulty is in moving the HeapRequirement
 226 stuff somewhere appropriate.  (The advantage is that we could simplify
 227 @CCallOp@ and record just the number of arguments with corresponding
 228 simplifications in reading pragma unfoldings, the simplifier,
 229 instantiation (etc) of core expressions, ... .  Maybe we should think
 230 about using it this way?? ADR)
 231
 232 \begin{code}
 233     -- (... continued from above ... )
 234
 235     -- one to support "errorIO" (and, thereby, "error")
 236     | ErrorIOPrimOp
 237
 238     -- Operation to test two closure addresses for equality (yes really!)
 239     -- BLAME ALASTAIR REID FOR THIS!  THE REST OF US ARE INNOCENT!
 240     | ReallyUnsafePtrEqualityOp
 241
 242     -- three for parallel stuff
 243     | SeqOp
 244     | ParOp
 245     | ForkOp
 246
 247     -- two for concurrency
 248     | DelayOp
 249     | WaitOp
 250
 251 #ifdef GRAN
 252     | ParGlobalOp       -- named global par
 253     | ParLocalOp        -- named local par
 254     | ParAtOp           -- specifies destination of local par
 255     | ParAtForNowOp     -- specifies initial destination of global par
 256     | CopyableOp        -- marks copyable code
 257     | NoFollowOp        -- marks non-followup expression
 258 #endif {-GRAN-}
 259
 260 #ifdef DPH
 261 -- Shadow all the the above primitive OPs for N dimensioned objects.
 262     | PodNPrimOp Int PrimOp
 263
 264 -- Primitive conversion functions.
 265
 266     | Int2PodNOp Int     | Char2PodNOp Int    | Float2PodNOp Int
 267     | Double2PodNOp Int  | String2PodNOp Int
 268
 269 #endif {-Data Parallel Haskell -}
 270 \end{code}
 271
 272 Deriving Ix is what we really want! ToDo
 273 (Chk around before deleting...)
 274 \begin{code}
 275 tagOf_PrimOp CharGtOp                   = (ILIT(1) :: FAST_INT)
 276 tagOf_PrimOp CharGeOp                   = ILIT(  2)
 277 tagOf_PrimOp CharEqOp                   = ILIT(  3)
 278 tagOf_PrimOp CharNeOp                   = ILIT(  4)
 279 tagOf_PrimOp CharLtOp                   = ILIT(  5)
 280 tagOf_PrimOp CharLeOp                   = ILIT(  6)
 281 tagOf_PrimOp IntGtOp                    = ILIT(  7)
 282 tagOf_PrimOp IntGeOp                    = ILIT(  8)
 283 tagOf_PrimOp IntEqOp                    = ILIT(  9)
 284 tagOf_PrimOp IntNeOp                    = ILIT( 10)
 285 tagOf_PrimOp IntLtOp                    = ILIT( 11)
 286 tagOf_PrimOp IntLeOp                    = ILIT( 12)
 287 tagOf_PrimOp WordGtOp                   = ILIT( 13)
 288 tagOf_PrimOp WordGeOp                   = ILIT( 14)
 289 tagOf_PrimOp WordEqOp                   = ILIT( 15)
 290 tagOf_PrimOp WordNeOp                   = ILIT( 16)
 291 tagOf_PrimOp WordLtOp                   = ILIT( 17)
 292 tagOf_PrimOp WordLeOp                   = ILIT( 18)
 293 tagOf_PrimOp AddrGtOp                   = ILIT( 19)
 294 tagOf_PrimOp AddrGeOp                   = ILIT( 20)
 295 tagOf_PrimOp AddrEqOp                   = ILIT( 21)
 296 tagOf_PrimOp AddrNeOp                   = ILIT( 22)
 297 tagOf_PrimOp AddrLtOp                   = ILIT( 23)
 298 tagOf_PrimOp AddrLeOp                   = ILIT( 24)
 299 tagOf_PrimOp FloatGtOp                  = ILIT( 25)
 300 tagOf_PrimOp FloatGeOp                  = ILIT( 26)
 301 tagOf_PrimOp FloatEqOp                  = ILIT( 27)
 302 tagOf_PrimOp FloatNeOp                  = ILIT( 28)
 303 tagOf_PrimOp FloatLtOp                  = ILIT( 29)
 304 tagOf_PrimOp FloatLeOp                  = ILIT( 30)
 305 tagOf_PrimOp DoubleGtOp                 = ILIT( 31)
 306 tagOf_PrimOp DoubleGeOp                 = ILIT( 32)
 307 tagOf_PrimOp DoubleEqOp                 = ILIT( 33)
 308 tagOf_PrimOp DoubleNeOp                 = ILIT( 34)
 309 tagOf_PrimOp DoubleLtOp                 = ILIT( 35)
 310 tagOf_PrimOp DoubleLeOp                 = ILIT( 36)
 311 tagOf_PrimOp OrdOp                      = ILIT( 37)
 312 tagOf_PrimOp ChrOp                      = ILIT( 38)
 313 tagOf_PrimOp IntAddOp                   = ILIT( 39)
 314 tagOf_PrimOp IntSubOp                   = ILIT( 40)
 315 tagOf_PrimOp IntMulOp                   = ILIT( 41)
 316 tagOf_PrimOp IntQuotOp                  = ILIT( 42)
 317 tagOf_PrimOp IntDivOp                   = ILIT( 43)
 318 tagOf_PrimOp IntRemOp                   = ILIT( 44)
 319 tagOf_PrimOp IntNegOp                   = ILIT( 45)
 320 tagOf_PrimOp IntAbsOp                   = ILIT( 46)
 321 tagOf_PrimOp AndOp                      = ILIT( 47)
 322 tagOf_PrimOp OrOp                       = ILIT( 48)
 323 tagOf_PrimOp NotOp                      = ILIT( 49)
 324 tagOf_PrimOp SllOp                      = ILIT( 50)
 325 tagOf_PrimOp SraOp                      = ILIT( 51)
 326 tagOf_PrimOp SrlOp                      = ILIT( 52)
 327 tagOf_PrimOp ISllOp                     = ILIT( 53)
 328 tagOf_PrimOp ISraOp                     = ILIT( 54)
 329 tagOf_PrimOp ISrlOp                     = ILIT( 55)
 330 tagOf_PrimOp Int2WordOp                 = ILIT( 56)
 331 tagOf_PrimOp Word2IntOp                 = ILIT( 57)
 332 tagOf_PrimOp Int2AddrOp                 = ILIT( 58)
 333 tagOf_PrimOp Addr2IntOp                 = ILIT( 59)
 334 tagOf_PrimOp FloatAddOp                 = ILIT( 60)
 335 tagOf_PrimOp FloatSubOp                 = ILIT( 61)
 336 tagOf_PrimOp FloatMulOp                 = ILIT( 62)
 337 tagOf_PrimOp FloatDivOp                 = ILIT( 63)
 338 tagOf_PrimOp FloatNegOp                 = ILIT( 64)
 339 tagOf_PrimOp Float2IntOp                = ILIT( 65)
 340 tagOf_PrimOp Int2FloatOp                = ILIT( 66)
 341 tagOf_PrimOp FloatExpOp                 = ILIT( 67)
 342 tagOf_PrimOp FloatLogOp                 = ILIT( 68)
 343 tagOf_PrimOp FloatSqrtOp                = ILIT( 69)
 344 tagOf_PrimOp FloatSinOp                 = ILIT( 70)
 345 tagOf_PrimOp FloatCosOp                 = ILIT( 71)
 346 tagOf_PrimOp FloatTanOp                 = ILIT( 72)
 347 tagOf_PrimOp FloatAsinOp                = ILIT( 73)
 348 tagOf_PrimOp FloatAcosOp                = ILIT( 74)
 349 tagOf_PrimOp FloatAtanOp                = ILIT( 75)
 350 tagOf_PrimOp FloatSinhOp                = ILIT( 76)
 351 tagOf_PrimOp FloatCoshOp                = ILIT( 77)
 352 tagOf_PrimOp FloatTanhOp                = ILIT( 78)
 353 tagOf_PrimOp FloatPowerOp               = ILIT( 79)
 354 tagOf_PrimOp DoubleAddOp                = ILIT( 80)
 355 tagOf_PrimOp DoubleSubOp                = ILIT( 81)
 356 tagOf_PrimOp DoubleMulOp                = ILIT( 82)
 357 tagOf_PrimOp DoubleDivOp                = ILIT( 83)
 358 tagOf_PrimOp DoubleNegOp                = ILIT( 84)
 359 tagOf_PrimOp Double2IntOp               = ILIT( 85)
 360 tagOf_PrimOp Int2DoubleOp               = ILIT( 86)
 361 tagOf_PrimOp Double2FloatOp             = ILIT( 87)
 362 tagOf_PrimOp Float2DoubleOp             = ILIT( 88)
 363 tagOf_PrimOp DoubleExpOp                = ILIT( 89)
 364 tagOf_PrimOp DoubleLogOp                = ILIT( 90)
 365 tagOf_PrimOp DoubleSqrtOp               = ILIT( 91)
 366 tagOf_PrimOp DoubleSinOp                = ILIT( 92)
 367 tagOf_PrimOp DoubleCosOp                = ILIT( 93)
 368 tagOf_PrimOp DoubleTanOp                = ILIT( 94)
 369 tagOf_PrimOp DoubleAsinOp               = ILIT( 95)
 370 tagOf_PrimOp DoubleAcosOp               = ILIT( 96)
 371 tagOf_PrimOp DoubleAtanOp               = ILIT( 97)
 372 tagOf_PrimOp DoubleSinhOp               = ILIT( 98)
 373 tagOf_PrimOp DoubleCoshOp               = ILIT( 99)
 374 tagOf_PrimOp DoubleTanhOp               = ILIT(100)
 375 tagOf_PrimOp DoublePowerOp              = ILIT(101)
 376 tagOf_PrimOp IntegerAddOp               = ILIT(102)
 377 tagOf_PrimOp IntegerSubOp               = ILIT(103)
 378 tagOf_PrimOp IntegerMulOp               = ILIT(104)
 379 tagOf_PrimOp IntegerQuotRemOp           = ILIT(105)
 380 tagOf_PrimOp IntegerDivModOp            = ILIT(106)
 381 tagOf_PrimOp IntegerNegOp               = ILIT(107)
 382 tagOf_PrimOp IntegerCmpOp               = ILIT(108)
 383 tagOf_PrimOp Integer2IntOp              = ILIT(109)
 384 tagOf_PrimOp Int2IntegerOp              = ILIT(110)
 385 tagOf_PrimOp Word2IntegerOp             = ILIT(111)
 386 tagOf_PrimOp Addr2IntegerOp             = ILIT(112)
 387 tagOf_PrimOp FloatEncodeOp              = ILIT(113)
 388 tagOf_PrimOp FloatDecodeOp              = ILIT(114)
 389 tagOf_PrimOp DoubleEncodeOp             = ILIT(115)
 390 tagOf_PrimOp DoubleDecodeOp             = ILIT(116)
 391 tagOf_PrimOp NewArrayOp                 = ILIT(117)
 392 tagOf_PrimOp (NewByteArrayOp CharKind)  = ILIT(118)
 393 tagOf_PrimOp (NewByteArrayOp IntKind)   = ILIT(119)
 394 tagOf_PrimOp (NewByteArrayOp AddrKind)  = ILIT(120)
 395 tagOf_PrimOp (NewByteArrayOp FloatKind) = ILIT(121)
 396 tagOf_PrimOp (NewByteArrayOp DoubleKind)= ILIT(122)
 397 tagOf_PrimOp SameMutableArrayOp         = ILIT(123)
 398 tagOf_PrimOp SameMutableByteArrayOp     = ILIT(124)
 399 tagOf_PrimOp ReadArrayOp                = ILIT(125)
 400 tagOf_PrimOp WriteArrayOp               = ILIT(126)
 401 tagOf_PrimOp IndexArrayOp               = ILIT(127)
 402 tagOf_PrimOp (ReadByteArrayOp CharKind)     = ILIT(128)
 403 tagOf_PrimOp (ReadByteArrayOp IntKind)      = ILIT(129)
 404 tagOf_PrimOp (ReadByteArrayOp AddrKind)     = ILIT(130)
 405 tagOf_PrimOp (ReadByteArrayOp FloatKind)    = ILIT(131)
 406 tagOf_PrimOp (ReadByteArrayOp DoubleKind)   = ILIT(132)
 407 tagOf_PrimOp (WriteByteArrayOp CharKind)    = ILIT(133)
 408 tagOf_PrimOp (WriteByteArrayOp IntKind)     = ILIT(134)
 409 tagOf_PrimOp (WriteByteArrayOp AddrKind)    = ILIT(135)
 410 tagOf_PrimOp (WriteByteArrayOp FloatKind)   = ILIT(136)
 411 tagOf_PrimOp (WriteByteArrayOp DoubleKind)  = ILIT(137)
 412 tagOf_PrimOp (IndexByteArrayOp CharKind)    = ILIT(138)
 413 tagOf_PrimOp (IndexByteArrayOp IntKind)     = ILIT(139)
 414 tagOf_PrimOp (IndexByteArrayOp AddrKind)    = ILIT(140)
 415 tagOf_PrimOp (IndexByteArrayOp FloatKind)   = ILIT(141)
 416 tagOf_PrimOp (IndexByteArrayOp DoubleKind)  = ILIT(142)
 417 tagOf_PrimOp (IndexOffAddrOp CharKind)      = ILIT(143)
 418 tagOf_PrimOp (IndexOffAddrOp IntKind)       = ILIT(144)
 419 tagOf_PrimOp (IndexOffAddrOp AddrKind)      = ILIT(145)
 420 tagOf_PrimOp (IndexOffAddrOp FloatKind)     = ILIT(146)
 421 tagOf_PrimOp (IndexOffAddrOp DoubleKind)    = ILIT(147)
 422 tagOf_PrimOp UnsafeFreezeArrayOp            = ILIT(148)
 423 tagOf_PrimOp UnsafeFreezeByteArrayOp        = ILIT(149)
 424 tagOf_PrimOp NewSynchVarOp                  = ILIT(150)
 425 tagOf_PrimOp TakeMVarOp                     = ILIT(151)
 426 tagOf_PrimOp PutMVarOp                      = ILIT(152)
 427 tagOf_PrimOp ReadIVarOp                     = ILIT(153)
 428 tagOf_PrimOp WriteIVarOp                    = ILIT(154)
 429 tagOf_PrimOp MakeStablePtrOp                = ILIT(155)
 430 tagOf_PrimOp DeRefStablePtrOp               = ILIT(156)
 431 tagOf_PrimOp (CCallOp _ _ _ _ _)            = ILIT(157)
 432 tagOf_PrimOp ErrorIOPrimOp                  = ILIT(158)
 433 tagOf_PrimOp ReallyUnsafePtrEqualityOp      = ILIT(159)
 434 tagOf_PrimOp SeqOp                          = ILIT(160)
 435 tagOf_PrimOp ParOp                          = ILIT(161)
 436 tagOf_PrimOp ForkOp                         = ILIT(162)
 437 tagOf_PrimOp DelayOp                        = ILIT(163)
 438 tagOf_PrimOp WaitOp                         = ILIT(164)
 439
 440 #ifdef GRAN
 441 tagOf_PrimOp ParGlobalOp                    = ILIT(165)
 442 tagOf_PrimOp ParLocalOp                     = ILIT(166)
 443 tagOf_PrimOp ParAtOp                        = ILIT(167)
 444 tagOf_PrimOp ParAtForNowOp                  = ILIT(168)
 445 tagOf_PrimOp CopyableOp                     = ILIT(169)
 446 tagOf_PrimOp NoFollowOp                     = ILIT(170)
 447 #endif {-GRAN-}
 448
 449 #ifdef DPH
 450 tagOf_PrimOp (PodNPrimOp _ _)           = panic "ToDo:DPH:tagOf_PrimOp"
 451 tagOf_PrimOp (Int2PodNOp _)             = panic "ToDo:DPH:tagOf_PrimOp"
 452 tagOf_PrimOp (Char2PodNOp _)            = panic "ToDo:DPH:tagOf_PrimOp"
 453 tagOf_PrimOp (Float2PodNOp  _)          = panic "ToDo:DPH:tagOf_PrimOp"
 454 tagOf_PrimOp (Double2PodNOp _)          = panic "ToDo:DPH:tagOf_PrimOp"
 455 tagOf_PrimOp (String2PodNOp _)          = panic "ToDo:DPH:tagOf_PrimOp"
 456 #endif {-Data Parallel Haskell -}
 457
 458 -- avoid BUG
 459 tagOf_PrimOp _ = case (panic "tagOf_PrimOp: pattern-match") of { o ->
 460                  tagOf_PrimOp o
 461                  }
 462
 463 instance Eq PrimOp where
 464     op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
 465 \end{code}
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection[PrimOps-info]{The essential info about each @PrimOp@}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may
 474 refer to the primitive operation.  The conventional \tr{#}-for-
 475 unboxed ops is added on later.
 476
 477 The reason for the funny characters in the names is so we do not
 478 interfere with the programmer's Haskell name spaces.
 479
 480 We use @PrimKinds@ for the ``type'' information, because they're
 481 (slightly) more convenient to use than @TyCons@.
 482 \begin{code}
 483 data PrimOpInfo
 484   = Dyadic      FAST_STRING     -- string :: T -> T -> T
 485                 UniType
 486   | Monadic     FAST_STRING     -- string :: T -> T
 487                 UniType
 488   | Compare     FAST_STRING     -- string :: T -> T -> Bool
 489                 UniType
 490   | Coerce      FAST_STRING     -- string :: T1 -> T2
 491                 UniType
 492                 UniType
 493
 494   | PrimResult  FAST_STRING
 495                 [TyVarTemplate] [UniType] TyCon PrimKind [UniType]
 496                 -- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
 497                 -- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
 498                 -- D# is a primitive type constructor.
 499                 -- (the kind is the same info as D#, in another convenient form)
 500
 501   | AlgResult   FAST_STRING
 502                 [TyVarTemplate] [UniType] TyCon [UniType]
 503                 -- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
 504                 -- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
 505
 506 -- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
 507
 508 #ifdef DPH
 509   | PodNInfo    Int
 510                 PrimOpInfo
 511 #endif {- Data Parallel Haskell -}
 512 \end{code}
 513
 514 Utility bits:
 515 \begin{code}
 516 one_Integer_ty = [intPrimTy, intPrimTy, byteArrayPrimTy]
 517 two_Integer_tys
 518   = [intPrimTy, intPrimTy, byteArrayPrimTy, -- first Integer pieces
 519      intPrimTy, intPrimTy, byteArrayPrimTy] -- second '' pieces
 520 an_Integer_and_Int_tys
 521   = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer
 522      intPrimTy]
 523
 524 integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon []
 525
 526 integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon []
 527
 528 integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
 529
 530 integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntKind []
 531 \end{code}
 532
 533 @primOpInfo@ gives all essential information (from which everything
 534 else, notably a type, can be constructed) for each @PrimOp@.
 535
 536 \begin{code}
 537 primOpInfo :: PrimOp -> PrimOpInfo
 538 \end{code}
 539
 540 There's plenty of this stuff!
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsubsection[PrimOps-comparison]{PrimOpInfo basic comparison ops}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 \begin{code}
 549 primOpInfo CharGtOp   = Compare SLIT("gtChar#")   charPrimTy
 550 primOpInfo CharGeOp   = Compare SLIT("geChar#")   charPrimTy
 551 primOpInfo CharEqOp   = Compare SLIT("eqChar#")   charPrimTy
 552 primOpInfo CharNeOp   = Compare SLIT("neChar#")   charPrimTy
 553 primOpInfo CharLtOp   = Compare SLIT("ltChar#")   charPrimTy
 554 primOpInfo CharLeOp   = Compare SLIT("leChar#")   charPrimTy
 555
 556 primOpInfo IntGtOp    = Compare SLIT("gtInt#")     intPrimTy
 557 primOpInfo IntGeOp    = Compare SLIT("geInt#")     intPrimTy
 558 primOpInfo IntEqOp    = Compare SLIT("eqInt#")     intPrimTy
 559 primOpInfo IntNeOp    = Compare SLIT("neInt#")     intPrimTy
 560 primOpInfo IntLtOp    = Compare SLIT("ltInt#")     intPrimTy
 561 primOpInfo IntLeOp    = Compare SLIT("leInt#")     intPrimTy
 562
 563 primOpInfo WordGtOp   = Compare SLIT("gtWord#")   wordPrimTy
 564 primOpInfo WordGeOp   = Compare SLIT("geWord#")   wordPrimTy
 565 primOpInfo WordEqOp   = Compare SLIT("eqWord#")   wordPrimTy
 566 primOpInfo WordNeOp   = Compare SLIT("neWord#")   wordPrimTy
 567 primOpInfo WordLtOp   = Compare SLIT("ltWord#")   wordPrimTy
 568 primOpInfo WordLeOp   = Compare SLIT("leWord#")   wordPrimTy
 569
 570 primOpInfo AddrGtOp   = Compare SLIT("gtAddr#")   addrPrimTy
 571 primOpInfo AddrGeOp   = Compare SLIT("geAddr#")   addrPrimTy
 572 primOpInfo AddrEqOp   = Compare SLIT("eqAddr#")   addrPrimTy
 573 primOpInfo AddrNeOp   = Compare SLIT("neAddr#")   addrPrimTy
 574 primOpInfo AddrLtOp   = Compare SLIT("ltAddr#")   addrPrimTy
 575 primOpInfo AddrLeOp   = Compare SLIT("leAddr#")   addrPrimTy
 576
 577 primOpInfo FloatGtOp  = Compare SLIT("gtFloat#")  floatPrimTy
 578 primOpInfo FloatGeOp  = Compare SLIT("geFloat#")  floatPrimTy
 579 primOpInfo FloatEqOp  = Compare SLIT("eqFloat#")  floatPrimTy
 580 primOpInfo FloatNeOp  = Compare SLIT("neFloat#")  floatPrimTy
 581 primOpInfo FloatLtOp  = Compare SLIT("ltFloat#")  floatPrimTy
 582 primOpInfo FloatLeOp  = Compare SLIT("leFloat#")  floatPrimTy
 583
 584 primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
 585 primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
 586 primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
 587 primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy
 588 primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy
 589 primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
 590 \end{code}
 591
 592 %************************************************************************
 593 %*                                                                      *
 594 \subsubsection[PrimOps-Char]{PrimOpInfo for @Char#@s}
 595 %*                                                                      *
 596 %************************************************************************
 597
 598 \begin{code}
 599 primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy
 600 primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy
 601 \end{code}
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsubsection[PrimOps-Int]{PrimOpInfo for @Int#@s}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 \begin{code}
 610 primOpInfo IntAddOp  = Dyadic SLIT("plusInt#")   intPrimTy
 611 primOpInfo IntSubOp  = Dyadic SLIT("minusInt#") intPrimTy
 612 primOpInfo IntMulOp  = Dyadic SLIT("timesInt#") intPrimTy
 613 primOpInfo IntQuotOp = Dyadic SLIT("quotInt#")   intPrimTy
 614 primOpInfo IntDivOp  = Dyadic SLIT("divInt#")    intPrimTy
 615 primOpInfo IntRemOp  = Dyadic SLIT("remInt#")    intPrimTy
 616
 617 primOpInfo IntNegOp  = Monadic SLIT("negateInt#") intPrimTy
 618 \end{code}
 619
 620 %************************************************************************
 621 %*                                                                      *
 622 \subsubsection[PrimOps-Word]{PrimOpInfo for @Word#@s}
 623 %*                                                                      *
 624 %************************************************************************
 625
 626 A @Word#@ is an unsigned @Int#@.
 627
 628 \begin{code}
 629 primOpInfo AndOp    = Dyadic  SLIT("and#")      wordPrimTy
 630 primOpInfo OrOp     = Dyadic  SLIT("or#")       wordPrimTy
 631 primOpInfo NotOp    = Monadic SLIT("not#")      wordPrimTy
 632
 633 primOpInfo SllOp
 634   = PrimResult SLIT("shiftL#")  [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
 635 primOpInfo SraOp
 636   = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
 637 primOpInfo SrlOp
 638   = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
 639
 640 primOpInfo ISllOp
 641   = PrimResult SLIT("iShiftL#")  [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
 642 primOpInfo ISraOp
 643   = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
 644 primOpInfo ISrlOp
 645   = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
 646
 647 primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
 648 primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
 649 \end{code}
 650
 651 %************************************************************************
 652 %*                                                                      *
 653 \subsubsection[PrimOps-Addr]{PrimOpInfo for @Addr#@s}
 654 %*                                                                      *
 655 %************************************************************************
 656
 657 \begin{code}
 658 primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy
 659 primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsubsection[PrimOps-Float]{PrimOpInfo for @Float#@s}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 @encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's
 669 similar).
 670
 671 \begin{code}
 672 primOpInfo FloatAddOp   = Dyadic    SLIT("plusFloat#")     floatPrimTy
 673 primOpInfo FloatSubOp   = Dyadic    SLIT("minusFloat#")   floatPrimTy
 674 primOpInfo FloatMulOp   = Dyadic    SLIT("timesFloat#")   floatPrimTy
 675 primOpInfo FloatDivOp   = Dyadic    SLIT("divideFloat#")  floatPrimTy
 676 primOpInfo FloatNegOp   = Monadic   SLIT("negateFloat#")  floatPrimTy
 677
 678 primOpInfo Float2IntOp  = Coerce SLIT("float2Int#") floatPrimTy intPrimTy
 679 primOpInfo Int2FloatOp  = Coerce SLIT("int2Float#") intPrimTy floatPrimTy
 680
 681 primOpInfo FloatExpOp   = Monadic   SLIT("expFloat#")      floatPrimTy
 682 primOpInfo FloatLogOp   = Monadic   SLIT("logFloat#")      floatPrimTy
 683 primOpInfo FloatSqrtOp  = Monadic   SLIT("sqrtFloat#")     floatPrimTy
 684 primOpInfo FloatSinOp   = Monadic   SLIT("sinFloat#")      floatPrimTy
 685 primOpInfo FloatCosOp   = Monadic   SLIT("cosFloat#")      floatPrimTy
 686 primOpInfo FloatTanOp   = Monadic   SLIT("tanFloat#")      floatPrimTy
 687 primOpInfo FloatAsinOp  = Monadic   SLIT("asinFloat#")     floatPrimTy
 688 primOpInfo FloatAcosOp  = Monadic   SLIT("acosFloat#")     floatPrimTy
 689 primOpInfo FloatAtanOp  = Monadic   SLIT("atanFloat#")     floatPrimTy
 690 primOpInfo FloatSinhOp  = Monadic   SLIT("sinhFloat#")     floatPrimTy
 691 primOpInfo FloatCoshOp  = Monadic   SLIT("coshFloat#")     floatPrimTy
 692 primOpInfo FloatTanhOp  = Monadic   SLIT("tanhFloat#")     floatPrimTy
 693 primOpInfo FloatPowerOp = Dyadic    SLIT("powerFloat#")   floatPrimTy
 694 \end{code}
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsubsection[PrimOps-Double]{PrimOpInfo for @Double#@s}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 @encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's
 703 similar).
 704
 705 \begin{code}
 706 primOpInfo DoubleAddOp  = Dyadic    SLIT("plusDouble#")   doublePrimTy
 707 primOpInfo DoubleSubOp  = Dyadic    SLIT("minusDouble#")  doublePrimTy
 708 primOpInfo DoubleMulOp  = Dyadic    SLIT("timesDouble#")  doublePrimTy
 709 primOpInfo DoubleDivOp  = Dyadic    SLIT("divideDouble#") doublePrimTy
 710 primOpInfo DoubleNegOp  = Monadic   SLIT("negateDouble#") doublePrimTy
 711
 712 primOpInfo Double2IntOp     = Coerce SLIT("double2Int#")   doublePrimTy intPrimTy
 713 primOpInfo Int2DoubleOp     = Coerce SLIT("int2Double#")   intPrimTy doublePrimTy
 714
 715 primOpInfo Double2FloatOp   = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy
 716 primOpInfo Float2DoubleOp   = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy
 717
 718 primOpInfo DoubleExpOp  = Monadic   SLIT("expDouble#")     doublePrimTy
 719 primOpInfo DoubleLogOp  = Monadic   SLIT("logDouble#")     doublePrimTy
 720 primOpInfo DoubleSqrtOp = Monadic   SLIT("sqrtDouble#")   doublePrimTy
 721 primOpInfo DoubleSinOp  = Monadic   SLIT("sinDouble#")     doublePrimTy
 722 primOpInfo DoubleCosOp  = Monadic   SLIT("cosDouble#")     doublePrimTy
 723 primOpInfo DoubleTanOp  = Monadic   SLIT("tanDouble#")     doublePrimTy
 724 primOpInfo DoubleAsinOp = Monadic   SLIT("asinDouble#")   doublePrimTy
 725 primOpInfo DoubleAcosOp = Monadic   SLIT("acosDouble#")   doublePrimTy
 726 primOpInfo DoubleAtanOp = Monadic   SLIT("atanDouble#")   doublePrimTy
 727 primOpInfo DoubleSinhOp = Monadic   SLIT("sinhDouble#")   doublePrimTy
 728 primOpInfo DoubleCoshOp = Monadic   SLIT("coshDouble#")   doublePrimTy
 729 primOpInfo DoubleTanhOp = Monadic   SLIT("tanhDouble#")   doublePrimTy
 730 primOpInfo DoublePowerOp= Dyadic    SLIT("powerDouble#")  doublePrimTy
 731 \end{code}
 732
 733 %************************************************************************
 734 %*                                                                      *
 735 \subsubsection[PrimOps-Integer]{PrimOpInfo for @Integer@ (and related!)}
 736 %*                                                                      *
 737 %************************************************************************
 738
 739 \begin{code}
 740 primOpInfo IntegerNegOp = integerMonadic SLIT("negateInteger#")
 741
 742 primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#")
 743 primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#")
 744 primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#")
 745
 746 primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#")
 747
 748 primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#")
 749 primOpInfo IntegerDivModOp  = integerDyadic2Results SLIT("divModInteger#")
 750
 751 primOpInfo Integer2IntOp
 752   = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntKind []
 753
 754 primOpInfo Int2IntegerOp
 755   = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
 756
 757 primOpInfo Word2IntegerOp
 758   = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon []
 759
 760 primOpInfo Addr2IntegerOp
 761   = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon []
 762 \end{code}
 763
 764 Encoding and decoding of floating-point numbers is sorta
 765 Integer-related.
 766
 767 \begin{code}
 768 primOpInfo FloatEncodeOp
 769   = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
 770          floatPrimTyCon FloatKind []
 771
 772 primOpInfo DoubleEncodeOp
 773   = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
 774         doublePrimTyCon DoubleKind []
 775
 776 primOpInfo FloatDecodeOp
 777   = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
 778
 779 primOpInfo DoubleDecodeOp
 780   = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon []
 781 \end{code}
 782
 783 %************************************************************************
 784 %*                                                                      *
 785 \subsubsection[PrimOps-Arrays]{PrimOpInfo for primitive arrays}
 786 %*                                                                      *
 787 %************************************************************************
 788
 789 \begin{code}
 790 primOpInfo NewArrayOp
 791   = let {
 792         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 793     } in
 794     AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
 795                                 stateAndMutableArrayPrimTyCon [s, elt]
 796
 797 primOpInfo (NewByteArrayOp kind)
 798   = let
 799         s = alpha; s_tv = alpha_tv
 800
 801         (str, _, prim_tycon) = getKindInfo kind
 802
 803         op_str         = _PK_ ("new" ++ str ++ "Array#")
 804     in
 805     AlgResult op_str [s_tv]
 806         [intPrimTy, mkStatePrimTy s]
 807         stateAndMutableByteArrayPrimTyCon [s]
 808
 809 ---------------------------------------------------------------------------
 810
 811 primOpInfo SameMutableArrayOp
 812   = let {
 813         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv;
 814         mut_arr_ty = mkMutableArrayPrimTy s elt
 815     } in
 816     AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
 817                                    boolTyCon []
 818
 819 primOpInfo SameMutableByteArrayOp
 820   = let {
 821         s = alpha; s_tv = alpha_tv;
 822         mut_arr_ty = mkMutableByteArrayPrimTy s
 823     } in
 824     AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
 825                                    boolTyCon []
 826
 827 ---------------------------------------------------------------------------
 828 -- Primitive arrays of Haskell pointers:
 829
 830 primOpInfo ReadArrayOp
 831   = let {
 832         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 833     } in
 834     AlgResult SLIT("readArray#") [s_tv, elt_tv]
 835         [mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
 836         stateAndPtrPrimTyCon [s, elt]
 837
 838
 839 primOpInfo WriteArrayOp
 840   = let {
 841         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 842     } in
 843     PrimResult SLIT("writeArray#") [s_tv, elt_tv]
 844         [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
 845         statePrimTyCon VoidKind [s]
 846
 847 primOpInfo IndexArrayOp
 848   = let { elt = alpha; elt_tv = alpha_tv } in
 849     AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
 850                                    liftTyCon [elt]
 851
 852 ---------------------------------------------------------------------------
 853 -- Primitive arrays full of unboxed bytes:
 854
 855 primOpInfo (ReadByteArrayOp kind)
 856   = let
 857         s = alpha; s_tv = alpha_tv
 858
 859         (str, _, prim_tycon) = getKindInfo kind
 860
 861         op_str         = _PK_ ("read" ++ str ++ "Array#")
 862         relevant_tycon = assoc "primOpInfo" tbl kind
 863     in
 864     AlgResult op_str [s_tv]
 865         [mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
 866         relevant_tycon [s]
 867   where
 868     tbl = [ (CharKind,   stateAndCharPrimTyCon),
 869             (IntKind,    stateAndIntPrimTyCon),
 870             (AddrKind,   stateAndAddrPrimTyCon),
 871             (FloatKind,  stateAndFloatPrimTyCon),
 872             (DoubleKind, stateAndDoublePrimTyCon) ]
 873
 874   -- How come there's no Word byte arrays? ADR
 875
 876 primOpInfo (WriteByteArrayOp kind)
 877   = let
 878         s = alpha; s_tv = alpha_tv
 879
 880         (str, prim_ty, _) = getKindInfo kind
 881         op_str = _PK_ ("write" ++ str ++ "Array#")
 882     in
 883     -- NB: *Prim*Result --
 884     PrimResult op_str [s_tv]
 885         [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
 886         statePrimTyCon VoidKind [s]
 887
 888 primOpInfo (IndexByteArrayOp kind)
 889   = let
 890         (str, _, prim_tycon) = getKindInfo kind
 891         op_str = _PK_ ("index" ++ str ++ "Array#")
 892     in
 893     -- NB: *Prim*Result --
 894     PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind []
 895
 896 primOpInfo (IndexOffAddrOp kind)
 897   = let
 898         (str, _, prim_tycon) = getKindInfo kind
 899         op_str = _PK_ ("index" ++ str ++ "OffAddr#")
 900     in
 901     PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
 902
 903 ---------------------------------------------------------------------------
 904 primOpInfo UnsafeFreezeArrayOp
 905   = let {
 906         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 907     } in
 908     AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
 909         [mkMutableArrayPrimTy s elt, mkStatePrimTy s]
 910         stateAndArrayPrimTyCon [s, elt]
 911
 912 primOpInfo UnsafeFreezeByteArrayOp
 913   = let { s = alpha; s_tv = alpha_tv } in
 914     AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
 915         [mkMutableByteArrayPrimTy s, mkStatePrimTy s]
 916         stateAndByteArrayPrimTyCon [s]
 917 \end{code}
 918
 919 %************************************************************************
 920 %*                                                                      *
 921 \subsubsection[PrimOps-SynchVars]{PrimOpInfo for synchronizing Variables}
 922 %*                                                                      *
 923 %************************************************************************
 924
 925 \begin{code}
 926 primOpInfo NewSynchVarOp
 927   = let {
 928         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 929     } in
 930     AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
 931                                 stateAndSynchVarPrimTyCon [s, elt]
 932
 933 primOpInfo TakeMVarOp
 934   = let {
 935         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 936     } in
 937     AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
 938         [mkSynchVarPrimTy s elt, mkStatePrimTy s]
 939         stateAndPtrPrimTyCon [s, elt]
 940
 941 primOpInfo PutMVarOp
 942   = let {
 943         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 944     } in
 945     AlgResult SLIT("putMVar#") [s_tv, elt_tv]
 946         [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
 947         statePrimTyCon [s]
 948
 949 primOpInfo ReadIVarOp
 950   = let {
 951         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 952     } in
 953     AlgResult SLIT("readIVar#") [s_tv, elt_tv]
 954         [mkSynchVarPrimTy s elt, mkStatePrimTy s]
 955         stateAndPtrPrimTyCon [s, elt]
 956
 957 primOpInfo WriteIVarOp
 958   = let {
 959         elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
 960     } in
 961     AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
 962         [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
 963         statePrimTyCon [s]
 964
 965 \end{code}
 966
 967 %************************************************************************
 968 %*                                                                      *
 969 \subsubsection[PrimOps-Wait]{PrimOpInfo for delay/wait operations}
 970 %*                                                                      *
 971 %************************************************************************
 972
 973 \begin{code}
 974
 975 primOpInfo DelayOp
 976   = let {
 977         s = alpha; s_tv = alpha_tv
 978     } in
 979     PrimResult SLIT("delay#") [s_tv]
 980         [intPrimTy, mkStatePrimTy s]
 981         statePrimTyCon VoidKind [s]
 982
 983 primOpInfo WaitOp
 984   = let {
 985         s = alpha; s_tv = alpha_tv
 986     } in
 987     PrimResult SLIT("wait#") [s_tv]
 988         [intPrimTy, mkStatePrimTy s]
 989         statePrimTyCon VoidKind [s]
 990
 991 \end{code}
 992
 993
 994 %************************************************************************
 995 %*                                                                      *
 996 \subsubsection[PrimOps-stable-pointers]{PrimOpInfo for ``stable pointers''}
 997 %*                                                                      *
 998 %************************************************************************
 999
1000 A {\em stable pointer} is an index into a table of pointers into the
1001 heap.  Since the garbage collector is told about stable pointers, it
1002 is safe to pass a stable pointer to external systems such as C
1003 routines.
1004
1005 Here's what the operations and types are supposed to be (from
1006 state-interface document).
1007
1008 \begin{verbatim}
1009 makeStablePointer#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1010 freeStablePointer#  :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
1011 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1012 \end{verbatim}
1013
1014 It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
1015 operation since it doesn't (directly) involve IO operations.  The
1016 reason is that if some optimisation pass decided to duplicate calls to
1017 @makeStablePtr#@ and we only pass one of the stable pointers over, a
1018 massive space leak can result.  Putting it into the PrimIO monad
1019 prevents this.  (Another reason for putting them in a monad is to
1020 ensure correct sequencing wrt the side-effecting @freeStablePointer#@
1021 operation.)
1022
1023 Note that we can implement @freeStablePointer#@ using @_ccall_@ (and,
1024 besides, it's not likely to be used from Haskell) so it's not a
1025 primop.
1026
1027 Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR]
1028
1029 \begin{code}
1030 primOpInfo MakeStablePtrOp
1031   = AlgResult SLIT("makeStablePtr#") [alpha_tv]
1032         [alpha, realWorldStatePrimTy]
1033         stateAndStablePtrPrimTyCon [realWorldTy, alpha]
1034
1035 primOpInfo DeRefStablePtrOp
1036   = AlgResult SLIT("deRefStablePtr#") [alpha_tv]
1037         [mkStablePtrPrimTy alpha, realWorldStatePrimTy]
1038         stateAndPtrPrimTyCon [realWorldTy, alpha]
1039 \end{code}
1040
1041 %************************************************************************
1042 %*                                                                      *
1043 \subsubsection[PrimOps-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
1044 %*                                                                      *
1045 %************************************************************************
1046
1047 [Alastair Reid is to blame for this!]
1048
1049 These days, (Glasgow) Haskell seems to have a bit of everything from
1050 other languages: strict operations, mutable variables, sequencing,
1051 pointers, etc.  About the only thing left is LISP's ability to test
1052 for pointer equality.  So, let's add it in!
1053
1054 \begin{verbatim}
1055 reallyUnsafePtrEquality :: a -> a -> Int#
1056 \end{verbatim}
1057
1058 which tests any two closures (of the same type) to see if they're the
1059 same.  (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid
1060 difficulties of trying to box up the result.)
1061
1062 NB This is {\em really unsafe\/} because even something as trivial as
1063 a garbage collection might change the answer by removing indirections.
1064 Still, no-one's forcing you to use it.  If you're worried about little
1065 things like loss of referential transparency, you might like to wrap
1066 it all up in a monad-like thing as John O'Donnell and John Hughes did
1067 for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop
1068 Proceedings?)
1069
1070 I'm thinking of using it to speed up a critical equality test in some
1071 graphics stuff in a context where the possibility of saying that
1072 denotationally equal things aren't isn't a problem (as long as it
1073 doesn't happen too often.)  ADR
1074
1075 To Will: Jim said this was already in, but I can't see it so I'm
1076 adding it.  Up to you whether you add it.  (Note that this could have
1077 been readily implemented using a @veryDangerousCCall@ before they were
1078 removed...)
1079
1080 \begin{code}
1081 primOpInfo ReallyUnsafePtrEqualityOp
1082   = PrimResult SLIT("reallyUnsafePtrEquality#") [alpha_tv]
1083         [alpha, alpha] intPrimTyCon IntKind []
1084 \end{code}
1085
1086 %************************************************************************
1087 %*                                                                      *
1088 \subsubsection[PrimOps-parallel]{PrimOpInfo for parallelism op(s)}
1089 %*                                                                      *
1090 %************************************************************************
1091
1092 \begin{code}
1093 primOpInfo SeqOp        -- seq# :: a -> Int#
1094   = PrimResult SLIT("seq#")     [alpha_tv] [alpha] intPrimTyCon IntKind []
1095
1096 primOpInfo ParOp        -- par# :: a -> Int#
1097   = PrimResult SLIT("par#")     [alpha_tv] [alpha] intPrimTyCon IntKind []
1098
1099 primOpInfo ForkOp       -- fork# :: a -> Int#
1100   = PrimResult SLIT("fork#")    [alpha_tv] [alpha] intPrimTyCon IntKind []
1101
1102 \end{code}
1103
1104 \begin{code}
1105 #ifdef GRAN
1106
1107 primOpInfo ParGlobalOp  -- parGlobal# :: Int -> a -> b -> b
1108   = AlgResult SLIT("parGlobal#")        [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
1109
1110 primOpInfo ParLocalOp   -- parLocal# :: Int -> a -> b -> b
1111   = AlgResult SLIT("parLocal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
1112
1113 primOpInfo ParAtOp      -- parAt# :: Int -> a -> b -> c -> c
1114   = AlgResult SLIT("parAt#")    [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
1115
1116 primOpInfo ParAtForNowOp        -- parAtForNow# :: Int -> a -> b -> c -> c
1117   = AlgResult SLIT("parAtForNow#")      [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
1118
1119 primOpInfo CopyableOp   -- copyable# :: a -> a
1120   = AlgResult SLIT("copyable#") [alpha_tv] [alpha] liftTyCon [alpha]
1121
1122 primOpInfo NoFollowOp   -- noFollow# :: a -> a
1123   = AlgResult SLIT("noFollow#") [alpha_tv] [alpha] liftTyCon [alpha]
1124
1125 #endif {-GRAN-}
1126 \end{code}
1127
1128 %************************************************************************
1129 %*                                                                      *
1130 \subsubsection[PrimOps-errorIO]{PrimOpInfo for @errorIO#@}
1131 %*                                                                      *
1132 %************************************************************************
1133
1134 \begin{code}
1135 primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
1136   = PrimResult SLIT("errorIO#") []
1137         [mkPrimIoTy unitTy]
1138         statePrimTyCon VoidKind [realWorldTy]
1139 \end{code}
1140
1141 %************************************************************************
1142 %*                                                                      *
1143 \subsubsection[PrimOps-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
1144 %*                                                                      *
1145 %************************************************************************
1146
1147 \begin{code}
1148 primOpInfo (CCallOp _ _ _ arg_tys result_ty)
1149   = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
1150   where
1151     (result_tycon, tys_applied, _) = getUniDataTyCon result_ty
1152 \end{code}
1153
1154 %************************************************************************
1155 %*                                                                      *
1156 \subsubsection[PrimOps-DPH]{PrimOpInfo for Data Parallel Haskell}
1157 %*                                                                      *
1158 %************************************************************************
1159
1160 \begin{code}
1161 #ifdef DPH
1162 -- ToDo:DPH: various things need doing here
1163
1164 primOpInfo (Int2PodNOp d) =     Coerce ("int2Pod" ++ show d)
1165                                        IntKind
1166                                        (PodNKind d IntKind)
1167
1168 primOpInfo (Char2PodNOp d) =    Coerce ("char2Pod" ++ show d)
1169                                        CharKind
1170                                        (PodNKind d CharKind)
1171
1172 primOpInfo (Float2PodNOp d) =   Coerce ("float2Pod" ++ show d)
1173                                        FloatKind
1174                                        (PodNKind d FloatKind)
1175
1176 primOpInfo (Double2PodNOp d) =  Coerce ("double2Pod" ++ show d)
1177                                        DoubleKind
1178                                        (PodNKind d DoubleKind)
1179
1180 {-
1181 primOpInfo (Integer2PodNOp d) = Coerce ("integer2Pod" ++ show d)
1182                                        IntegerKind
1183                                        (PodNKind d IntegerKind)
1184 -}
1185
1186 primOpInfo (String2PodNOp d) =  Coerce ("string2Pod" ++ show d)
1187                                        LitStringKind
1188                                        (PodNKind d LitStringKind)
1189
1190 primOpInfo (PodNPrimOp d p) = PodNInfo d (primOpInfo p)
1191 #endif {- Data Parallel Haskell -}
1192 \end{code}
1193
1194 %************************************************************************
1195 %*                                                                      *
1196 \subsection[PrimOps-utils]{Utilities for @PrimitiveOps@}
1197 %*                                                                      *
1198 %************************************************************************
1199
1200 The primitive-array-creation @PrimOps@ and {\em most} of those to do
1201 with @Integers@ can trigger GC.  Here we describe the heap requirements
1202 of the various @PrimOps@.  For most, no heap is required.  For a few,
1203 a fixed amount of heap is required, and the needs of the @PrimOp@ can
1204 be combined with the rest of the heap usage in the basic block.  For an
1205 unfortunate few, some unknown amount of heap is required (these are the
1206 ops which can trigger GC).
1207
1208 \begin{code}
1209 data HeapRequirement
1210     = NoHeapRequired
1211     | FixedHeapRequired HeapOffset
1212     | VariableHeapRequired
1213
1214 primOpHeapReq :: PrimOp -> HeapRequirement
1215
1216 primOpHeapReq NewArrayOp        = VariableHeapRequired
1217 primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired
1218
1219 primOpHeapReq IntegerAddOp      = VariableHeapRequired
1220 primOpHeapReq IntegerSubOp      = VariableHeapRequired
1221 primOpHeapReq IntegerMulOp      = VariableHeapRequired
1222 primOpHeapReq IntegerQuotRemOp  = VariableHeapRequired
1223 primOpHeapReq IntegerDivModOp   = VariableHeapRequired
1224 primOpHeapReq IntegerNegOp      = VariableHeapRequired
1225 primOpHeapReq Int2IntegerOp     = FixedHeapRequired
1226                                   (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
1227                                           (intOff mIN_MP_INT_SIZE))
1228 primOpHeapReq Word2IntegerOp    = FixedHeapRequired
1229                                   (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
1230                                           (intOff mIN_MP_INT_SIZE))
1231 primOpHeapReq Addr2IntegerOp    = VariableHeapRequired
1232 primOpHeapReq FloatDecodeOp     = FixedHeapRequired
1233                                   (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
1234                                   (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
1235                                           (intOff mIN_MP_INT_SIZE)))
1236 primOpHeapReq DoubleDecodeOp    = FixedHeapRequired
1237                                   (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
1238                                   (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
1239                                           (intOff mIN_MP_INT_SIZE)))
1240
1241 -- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
1242 -- or if it returns a MallocPtr.
1243
1244 primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
1245 primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty)
1246    = if returnsMallocPtr
1247      then VariableHeapRequired
1248      else NoHeapRequired
1249   where
1250    returnsMallocPtr
1251      = case (getUniDataTyCon_maybe return_ty) of
1252          Nothing            -> False
1253          Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
1254
1255 -- this occasionally has to expand the Stable Pointer table
1256 primOpHeapReq MakeStablePtrOp   = VariableHeapRequired
1257
1258 -- These four only need heap space with the native code generator
1259 -- ToDo!: parameterize, so we know if native code generation is taking place(JSM)
1260
1261 primOpHeapReq IntegerCmpOp      = FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE))
1262 primOpHeapReq Integer2IntOp     = FixedHeapRequired (intOff mP_STRUCT_SIZE)
1263 primOpHeapReq FloatEncodeOp     = FixedHeapRequired (intOff mP_STRUCT_SIZE)
1264 primOpHeapReq DoubleEncodeOp    = FixedHeapRequired (intOff mP_STRUCT_SIZE)
1265
1266 -- a NewSynchVarOp creates a three-word mutuple in the heap.
1267 primOpHeapReq NewSynchVarOp     = FixedHeapRequired
1268                                   (addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
1269
1270 -- Sparking ops no longer allocate any heap; however, _fork_ may
1271 -- require a context switch to clear space in the required thread
1272 -- pool, and that requires liveness information.
1273
1274 primOpHeapReq ParOp             = NoHeapRequired
1275 primOpHeapReq ForkOp            = VariableHeapRequired
1276
1277 -- A SeqOp requires unknown space to evaluate its argument
1278 primOpHeapReq SeqOp             = VariableHeapRequired
1279
1280 #ifdef GRAN
1281
1282 -- a ParGlobalOp creates a single 4-tuple in the heap.  ToDo: verify this!
1283 primOpHeapReq ParGlobalOp       = trace "primOpHeapReq:ParGlobalOp:verify!" (
1284                                   FixedHeapRequired
1285                                   (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
1286                                   )
1287
1288 -- a ParLocalOp creates a single 4-tuple in the heap.  ToDo: verify this!
1289 primOpHeapReq ParLocalOp        = trace "primOpHeapReq:ParLocalOp:verify!" (
1290                                   FixedHeapRequired
1291                                   (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
1292                                   )
1293
1294 -- ToDo: parAt, parAtForNow, copyable, noFollow !!  (HWL)
1295 #endif {-GRAN-}
1296
1297 primOpHeapReq other_op          = NoHeapRequired
1298 \end{code}
1299
1300 Primops which can trigger GC have to be called carefully.
1301 In particular, their arguments are guaranteed to be in registers,
1302 and a liveness mask tells which regs are live.
1303
1304 \begin{code}
1305 primOpCanTriggerGC op =
1306     case op of
1307         TakeMVarOp  -> True
1308         ReadIVarOp  -> True
1309         DelayOp     -> True
1310         WaitOp      -> True
1311         _           ->
1312             case primOpHeapReq op of
1313                 VariableHeapRequired -> True
1314                 _                    -> False
1315
1316 \end{code}
1317
1318 Sometimes we may choose to execute a PrimOp even though it isn't
1319 certain that its result will be required; ie execute them
1320 ``speculatively''.  The same thing as ``cheap eagerness.'' Usually
1321 this is OK, because PrimOps are usually cheap, but it isn't OK for
1322 (a)~expensive PrimOps and (b)~PrimOps which can fail.
1323
1324 See also @primOpIsCheap@ (below).
1325
1326 There should be no worries about side effects; that's all taken care
1327 of by data dependencies.
1328
1329 \begin{code}
1330 primOpOkForSpeculation :: PrimOp -> Bool
1331
1332 -- Int.
1333 primOpOkForSpeculation IntDivOp         = False         -- Divide by zero
1334 primOpOkForSpeculation IntQuotOp        = False         -- Divide by zero
1335 primOpOkForSpeculation IntRemOp         = False         -- Divide by zero
1336
1337 -- Integer
1338 primOpOkForSpeculation IntegerQuotRemOp = False         -- Divide by zero
1339 primOpOkForSpeculation IntegerDivModOp  = False         -- Divide by zero
1340
1341 -- Float.  ToDo: tan? tanh?
1342 primOpOkForSpeculation FloatDivOp       = False         -- Divide by zero
1343 primOpOkForSpeculation FloatLogOp       = False         -- Log of zero
1344 primOpOkForSpeculation FloatAsinOp      = False         -- Arg out of domain
1345 primOpOkForSpeculation FloatAcosOp      = False         -- Arg out of domain
1346
1347 -- Double.  ToDo: tan? tanh?
1348 primOpOkForSpeculation DoubleDivOp      = False         -- Divide by zero
1349 primOpOkForSpeculation DoubleLogOp      = False         -- Log of zero
1350 primOpOkForSpeculation DoubleAsinOp     = False         -- Arg out of domain
1351 primOpOkForSpeculation DoubleAcosOp     = False         -- Arg out of domain
1352
1353 -- CCall
1354 primOpOkForSpeculation (CCallOp _ _ _ _ _)= False       -- Could be expensive!
1355
1356 -- errorIO#
1357 primOpOkForSpeculation ErrorIOPrimOp    = False         -- Could be disastrous!
1358
1359 -- parallel
1360 primOpOkForSpeculation ParOp            = False         -- Could be expensive!
1361 primOpOkForSpeculation ForkOp           = False         -- Likewise
1362 primOpOkForSpeculation SeqOp            = False         -- Likewise
1363
1364 #ifdef GRAN
1365 primOpOkForSpeculation ParGlobalOp      = False         -- Could be expensive!
1366 primOpOkForSpeculation ParLocalOp       = False         -- Could be expensive!
1367 #endif {-GRAN-}
1368
1369 -- The default is "yes it's ok for speculation"
1370 primOpOkForSpeculation other_op         = True
1371 \end{code}
1372
1373 @primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
1374 WARNING), we just borrow some other predicates for a
1375 what-should-be-good-enough test.
1376 \begin{code}
1377 primOpIsCheap op
1378   = primOpOkForSpeculation op && not (primOpCanTriggerGC op)
1379 \end{code}
1380
1381 And some primops have side-effects and so, for example, must not be
1382 duplicated.
1383
1384 \begin{code}
1385 fragilePrimOp :: PrimOp -> Bool
1386
1387 fragilePrimOp ParOp = True
1388 fragilePrimOp ForkOp = True
1389 fragilePrimOp SeqOp = True
1390 fragilePrimOp MakeStablePtrOp = True
1391 fragilePrimOp DeRefStablePtrOp = True  -- ??? JSM & ADR
1392
1393 #ifdef GRAN
1394 fragilePrimOp ParGlobalOp = True
1395 fragilePrimOp ParLocalOp = True
1396 fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True  -- Possibly not.  ASP
1397 fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True  -- Possibly not.  ASP
1398 #endif {-GRAN-}
1399
1400 fragilePrimOp other = False
1401 \end{code}
1402
1403 Primitive operations that perform calls need wrappers to save any live variables
1404 that are stored in caller-saves registers
1405
1406 \begin{code}
1407 primOpNeedsWrapper :: PrimOp -> Bool
1408
1409 primOpNeedsWrapper (CCallOp _ _ _ _ _)  = True
1410
1411 primOpNeedsWrapper IntDivOp             = True
1412
1413 primOpNeedsWrapper NewArrayOp           = True  -- ToDo: for nativeGen only!(JSM)
1414 primOpNeedsWrapper (NewByteArrayOp _)   = True
1415
1416 primOpNeedsWrapper IntegerAddOp         = True
1417 primOpNeedsWrapper IntegerSubOp         = True
1418 primOpNeedsWrapper IntegerMulOp         = True
1419 primOpNeedsWrapper IntegerQuotRemOp     = True
1420 primOpNeedsWrapper IntegerDivModOp      = True
1421 primOpNeedsWrapper IntegerNegOp         = True
1422 primOpNeedsWrapper IntegerCmpOp         = True
1423 primOpNeedsWrapper Integer2IntOp        = True
1424 primOpNeedsWrapper Int2IntegerOp        = True
1425 primOpNeedsWrapper Word2IntegerOp       = True
1426 primOpNeedsWrapper Addr2IntegerOp       = True
1427
1428 primOpNeedsWrapper FloatExpOp           = True
1429 primOpNeedsWrapper FloatLogOp           = True
1430 primOpNeedsWrapper FloatSqrtOp          = True
1431 primOpNeedsWrapper FloatSinOp           = True
1432 primOpNeedsWrapper FloatCosOp           = True
1433 primOpNeedsWrapper FloatTanOp           = True
1434 primOpNeedsWrapper FloatAsinOp          = True
1435 primOpNeedsWrapper FloatAcosOp          = True
1436 primOpNeedsWrapper FloatAtanOp          = True
1437 primOpNeedsWrapper FloatSinhOp          = True
1438 primOpNeedsWrapper FloatCoshOp          = True
1439 primOpNeedsWrapper FloatTanhOp          = True
1440 primOpNeedsWrapper FloatPowerOp         = True
1441 primOpNeedsWrapper FloatEncodeOp        = True
1442 primOpNeedsWrapper FloatDecodeOp        = True
1443
1444 primOpNeedsWrapper DoubleExpOp          = True
1445 primOpNeedsWrapper DoubleLogOp          = True
1446 primOpNeedsWrapper DoubleSqrtOp         = True
1447 primOpNeedsWrapper DoubleSinOp          = True
1448 primOpNeedsWrapper DoubleCosOp          = True
1449 primOpNeedsWrapper DoubleTanOp          = True
1450 primOpNeedsWrapper DoubleAsinOp         = True
1451 primOpNeedsWrapper DoubleAcosOp         = True
1452 primOpNeedsWrapper DoubleAtanOp         = True
1453 primOpNeedsWrapper DoubleSinhOp         = True
1454 primOpNeedsWrapper DoubleCoshOp         = True
1455 primOpNeedsWrapper DoubleTanhOp         = True
1456 primOpNeedsWrapper DoublePowerOp        = True
1457 primOpNeedsWrapper DoubleEncodeOp       = True
1458 primOpNeedsWrapper DoubleDecodeOp       = True
1459
1460 primOpNeedsWrapper MakeStablePtrOp      = True
1461 primOpNeedsWrapper DeRefStablePtrOp     = True
1462
1463 primOpNeedsWrapper TakeMVarOp           = True
1464 primOpNeedsWrapper PutMVarOp            = True
1465 primOpNeedsWrapper ReadIVarOp           = True
1466
1467 primOpNeedsWrapper DelayOp              = True
1468 primOpNeedsWrapper WaitOp               = True
1469
1470 primOpNeedsWrapper other_op             = False
1471 \end{code}
1472
1473 \begin{code}
1474 primOpId        :: PrimOp -> Id
1475 primOpNameInfo  :: PrimOp -> (FAST_STRING, Name)
1476
1477 -- the *NameInfo ones are trivial:
1478
1479 primOpNameInfo  op = (primOp_str  op, WiredInVal (primOpId op))
1480
1481 primOp_str op
1482   = case (primOpInfo op) of
1483       Dyadic str _             -> str
1484       Monadic str _            -> str
1485       Compare str _            -> str
1486       Coerce str _ _           -> str
1487       PrimResult str _ _ _ _ _ -> str
1488       AlgResult str _ _ _ _    -> str
1489 #ifdef DPH
1490       PodNInfo d i -> case i of
1491                         Dyadic str _    -> (str ++ ".POD" ++ show d ++ "#")
1492                         Monadic str _   -> (str ++ ".POD" ++ show d ++ "#")
1493                         Compare str _   -> (str ++ ".POD" ++ show d ++ "#")
1494                         Coerce str _ _  -> (str ++ ".POD" ++ show d ++ "#")
1495                         PrimResult str _ _ _ _ _ -> (str ++ ".POD" ++ show d)
1496                         AlgResult str _ _ _ _   -> (str ++ ".POD" ++ show d)
1497 #endif {- Data Parallel Haskell -}
1498 \end{code}
1499
1500 @typeOfPrimOp@ duplicates some work of @primOpId@, but since we
1501 grab types pretty often...
1502 \begin{code}
1503 typeOfPrimOp :: PrimOp -> UniType
1504
1505 #ifdef DPH
1506 typeOfPrimOp (PodNPrimOp d p)
1507   = mkPodizedPodNTy d (typeOfPrimOp p)
1508 #endif {- Data Parallel Haskell -}
1509
1510 typeOfPrimOp op
1511   = case (primOpInfo op) of
1512       Dyadic str ty ->      dyadic_fun_ty ty
1513       Monadic str ty ->     monadic_fun_ty ty
1514       Compare str ty ->     prim_compare_fun_ty ty
1515       Coerce str ty1 ty2 -> UniFun ty1 ty2
1516
1517       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
1518         mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
1519
1520       AlgResult str tyvars arg_tys tycon res_tys ->
1521         mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
1522 \end{code}
1523
1524 \begin{code}
1525 primOpId op
1526   = case (primOpInfo op) of
1527       Dyadic str ty ->
1528         mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
1529
1530       Monadic str ty ->
1531         mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
1532
1533       Compare str ty ->
1534         mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (prim_compare_fun_ty ty) 2
1535
1536       Coerce str ty1 ty2 ->
1537         mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (UniFun ty1 ty2) 1
1538
1539       PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
1540         mk_prim_Id op pRELUDE_BUILTIN str
1541             tyvars
1542             arg_tys
1543             (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)))
1544             (length arg_tys) -- arity
1545
1546       AlgResult str tyvars arg_tys tycon res_tys ->
1547         mk_prim_Id op pRELUDE_BUILTIN str
1548             tyvars
1549             arg_tys
1550             (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)))
1551             (length arg_tys) -- arity
1552
1553 #ifdef DPH
1554       PodNInfo d i -> panic "primOpId : Oi lazy, PodNInfo needs sorting out"
1555 #endif {- Data Parallel Haskell -}
1556   where
1557     mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
1558       = mkPreludeId
1559             (mkPrimOpIdUnique prim_op)
1560             (mkPreludeCoreName mod name)
1561             ty
1562             (noIdInfo
1563                 `addInfo` (mkArityInfo arity)
1564                 `addInfo_UF` (mkUnfolding EssentialUnfolding
1565                                 (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
1566 \end{code}
1567
1568 The functions to make common unfoldings are tedious.
1569
1570 \begin{code}
1571 mk_prim_unfold :: PrimOp -> [TyVarTemplate] -> [UniType] -> PlainCoreExpr{-template-}
1572
1573 mk_prim_unfold prim_op tv_tmpls arg_tys
1574   = let
1575         (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls (map getTheUnique tv_tmpls)
1576         inst_arg_tys                  = map (instantiateTauTy inst_env) arg_tys
1577         vars                          = mkTemplateLocals inst_arg_tys
1578     in
1579     foldr CoTyLam (mkCoLam vars
1580                            (CoPrim prim_op tyvar_tys [CoVarAtom v | v <- vars]))
1581                   tyvars
1582 \end{code}
1583
1584 \begin{code}
1585 data PrimOpResultInfo
1586   = ReturnsPrim     PrimKind
1587   | ReturnsAlg      TyCon
1588
1589 -- ToDo: Deal with specialised PrimOps
1590 --       Will need to return specialised tycon and data constructors
1591
1592 getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
1593
1594 getPrimOpResultInfo op
1595   = case (primOpInfo op) of
1596       Dyadic  _ ty               -> ReturnsPrim (kindFromType ty)
1597       Monadic _ ty               -> ReturnsPrim (kindFromType ty)
1598       Compare _ ty               -> ReturnsAlg  boolTyCon
1599       Coerce  _ _ ty             -> ReturnsPrim (kindFromType ty)
1600       PrimResult _ _ _ _ kind _  -> ReturnsPrim kind
1601       AlgResult _ _ _ tycon _    -> ReturnsAlg  tycon
1602 #ifdef DPH
1603       PodNInfo d i               -> panic "getPrimOpResultInfo:PodNInfo"
1604 #endif {- Data Parallel Haskell -}
1605
1606 isCompareOp :: PrimOp -> Bool
1607
1608 isCompareOp op
1609   = case primOpInfo op of
1610       Compare _ _ -> True
1611       _           -> False
1612 \end{code}
1613
1614 Utils:
1615 \begin{code}
1616 dyadic_fun_ty ty    = ty `UniFun` (ty `UniFun` ty)
1617 monadic_fun_ty ty   = ty `UniFun` ty
1618
1619 compare_fun_ty ty       = ty `UniFun` (ty `UniFun` boolTy)
1620 prim_compare_fun_ty ty  = ty `UniFun` (ty `UniFun` boolTy)
1621 \end{code}
1622
1623 Output stuff:
1624 \begin{code}
1625 pprPrimOp  :: PprStyle -> PrimOp -> Pretty
1626 showPrimOp :: PprStyle -> PrimOp -> String
1627
1628 showPrimOp sty op
1629   = ppShow 1000{-random-} (pprPrimOp sty op)
1630
1631 pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty)
1632   = let
1633         before
1634           = if is_casm then
1635                if may_gc then "(_casm_GC_ ``" else "(_casm_ ``"
1636             else
1637                if may_gc then "(_ccall_GC_ " else "(_ccall_ "
1638
1639         after
1640           = if is_casm then ppStr "''" else ppNil
1641
1642         pp_tys
1643           = ppBesides [ppStr " { [",
1644                 ppIntersperse pp'SP{-'-} (map (pprParendUniType sty) arg_tys),
1645                 ppRbrack, ppSP, pprParendUniType sty res_ty, ppStr " })"]
1646
1647     in
1648     ppBesides [ppStr before, ppPStr fun, after, pp_tys]
1649 #ifdef DPH
1650   = fun -- Comment buggers up machine code :-) -- ToDo:DPH
1651 #endif {- Data Parallel Haskell -}
1652
1653 pprPrimOp sty other_op
1654   = let
1655         str = primOp_str other_op
1656     in
1657     if codeStyle sty
1658     then identToC str
1659     else ppPStr str
1660
1661 instance Outputable PrimOp where
1662     ppr sty op = pprPrimOp sty op
1663 \end{code}