ghc/compiler/absCSyn/AbsCUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
   5
   6 \begin{code}
   7 module AbsCUtils (
   8         nonemptyAbsC,
   9         mkAbstractCs, mkAbsCStmts,
  10         mkAlgAltsCSwitch,
  11         magicIdPrimRep,
  12         getAmodeRep,
  13         mixedTypeLocn, mixedPtrLocn,
  14         flattenAbsC,
  15         mkAbsCStmtList
  16         -- printing/forcing stuff comes from PprAbsC
  17     ) where
  18
  19 #include "HsVersions.h"
  20 #include "../includes/config.h"
  21
  22 import AbsCSyn
  23 import CLabel           ( mkMAP_FROZEN_infoLabel )
  24 import Digraph          ( stronglyConnComp, SCC(..) )
  25 import DataCon          ( fIRST_TAG, dataConTag )
  26 import Literal          ( literalPrimRep, mkMachWord, mkMachInt )
  27 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  28 import PrimOp           ( PrimOp(..) )
  29 import MachOp           ( MachOp(..), isDefinitelyInlineMachOp )
  30 import Unique           ( Unique{-instance Eq-} )
  31 import UniqSupply       ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
  32                           UniqSupply )
  33 import CmdLineOpts      ( opt_EmitCExternDecls, opt_Unregisterised )
  34 import ForeignCall      ( ForeignCall(..), CCallSpec(..),
  35                           isDynamicTarget, isCasmTarget )
  36 import StgSyn           ( StgOp(..) )
  37 import CoreSyn          ( AltCon(..) )
  38 import SMRep            ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
  39 import Outputable
  40 import Panic            ( panic )
  41 import FastTypes
  42 import Constants        ( wORD_SIZE, wORD_SIZE_IN_BITS )
  43
  44 infixr 9 `thenFlt`
  45 \end{code}
  46
  47 Check if there is any real code in some Abstract~C.  If so, return it
  48 (@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
  49
  50 It returns the "reduced" code in the Just part so that the work of
  51 discarding AbsCNops isn't lost, and so that if the caller uses
  52 the reduced version there's less danger of a big tree of AbsCNops getting
  53 materialised and causing a space leak.
  54
  55 \begin{code}
  56 nonemptyAbsC :: AbstractC -> Maybe AbstractC
  57 nonemptyAbsC  AbsCNop           = Nothing
  58 nonemptyAbsC (AbsCStmts s1 s2)  = case (nonemptyAbsC s1) of
  59                                     Nothing -> nonemptyAbsC s2
  60                                     Just x  -> Just (AbsCStmts x s2)
  61 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
  62                                     Nothing -> Nothing
  63                                     Just x  -> Just s
  64 nonemptyAbsC other              = Just other
  65 \end{code}
  66
  67 \begin{code}
  68 mkAbstractCs :: [AbstractC] -> AbstractC
  69 mkAbstractCs [] = AbsCNop
  70 mkAbstractCs cs = foldr1 mkAbsCStmts cs
  71
  72 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
  73 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
  74 mkAbsCStmts AbsCNop c = c
  75 mkAbsCStmts c AbsCNop = c
  76 mkAbsCStmts c1 c2     = c1 `AbsCStmts` c2
  77
  78 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
  79   = case (case (nonemptyAbsC abc2) of
  80             Nothing -> AbsCNop
  81             Just d2 -> d2)      of { abc2b ->
  82
  83     case (nonemptyAbsC abc1) of {
  84       Nothing -> abc2b;
  85       Just d1 -> AbsCStmts d1 abc2b
  86     } }
  87 -}
  88 \end{code}
  89
  90 Get the sho' 'nuff statements out of an @AbstractC@.
  91 \begin{code}
  92 mkAbsCStmtList :: AbstractC -> [AbstractC]
  93
  94 mkAbsCStmtList absC = mkAbsCStmtList' absC []
  95
  96 -- Optimised a la foldr/build!
  97
  98 mkAbsCStmtList'  AbsCNop r = r
  99
 100 mkAbsCStmtList' (AbsCStmts s1 s2) r
 101   = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
 102
 103 mkAbsCStmtList' s@(CSimultaneous c) r
 104   = if null (mkAbsCStmtList c) then r else s : r
 105
 106 mkAbsCStmtList' other r = other : r
 107 \end{code}
 108
 109 \begin{code}
 110 mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
 111
 112 mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
 113  = CSwitch scrutinee (adjust rest_alts) first_alt
 114  where
 115    -- We use the first alt as the default.  Either it *is* the DEFAULT,
 116    -- (which is always first if present), or the case is exhaustive,
 117    -- in which case we can use the first as the default anyway
 118
 119    -- Adjust the tags in the switch to start at zero.
 120    -- This is the convention used by primitive ops which return algebraic
 121    -- data types.  Why?  Because for two-constructor types, zero is faster
 122    -- to create and distinguish from 1 than are 1 and 2.
 123
 124    -- We also need to convert to Literals to keep the CSwitch happy
 125    adjust tagged_alts
 126      = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
 127        | (DataAlt dc, abs_c) <- tagged_alts ]
 128 \end{code}
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 magicIdPrimRep BaseReg              = PtrRep
 138 magicIdPrimRep (VanillaReg kind _) = kind
 139 magicIdPrimRep (FloatReg _)         = FloatRep
 140 magicIdPrimRep (DoubleReg _)        = DoubleRep
 141 magicIdPrimRep (LongReg kind _)     = kind
 142 magicIdPrimRep Sp                   = PtrRep
 143 magicIdPrimRep SpLim                = PtrRep
 144 magicIdPrimRep Hp                   = PtrRep
 145 magicIdPrimRep HpLim                = PtrRep
 146 magicIdPrimRep CurCostCentre        = CostCentreRep
 147 magicIdPrimRep VoidReg              = VoidRep
 148 magicIdPrimRep CurrentTSO           = PtrRep
 149 magicIdPrimRep CurrentNursery       = PtrRep
 150 magicIdPrimRep HpAlloc              = WordRep
 151 \end{code}
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 See also the return conventions for unboxed things; currently living
 160 in @CgCon@ (next to the constructor return conventions).
 161
 162 ToDo: tiny tweaking may be in order
 163 \begin{code}
 164 getAmodeRep :: CAddrMode -> PrimRep
 165
 166 getAmodeRep (CVal _ kind)                   = kind
 167 getAmodeRep (CAddr _)                       = PtrRep
 168 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 169 getAmodeRep (CTemp uniq kind)               = kind
 170 getAmodeRep (CLbl _ kind)                   = kind
 171 getAmodeRep (CCharLike _)                   = PtrRep
 172 getAmodeRep (CIntLike _)                    = PtrRep
 173 getAmodeRep (CLit lit)                      = literalPrimRep lit
 174 getAmodeRep (CMacroExpr kind _ _)           = kind
 175 getAmodeRep (CJoinPoint _)                  = panic "getAmodeRep:CJoinPoint"
 176 \end{code}
 177
 178 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
 179 location; that is, one which can contain values of various types.
 180
 181 \begin{code}
 182 mixedTypeLocn :: CAddrMode -> Bool
 183
 184 mixedTypeLocn (CVal (NodeRel _) _)      = True
 185 mixedTypeLocn (CVal (SpRel _)   _)      = True
 186 mixedTypeLocn (CVal (HpRel _)   _)      = True
 187 mixedTypeLocn other                     = False -- All the rest
 188 \end{code}
 189
 190 @mixedPtrLocn@ tells whether an amode identifies a
 191 location which can contain values of various pointer types.
 192
 193 \begin{code}
 194 mixedPtrLocn :: CAddrMode -> Bool
 195
 196 mixedPtrLocn (CVal (SpRel _)  _)        = True
 197 mixedPtrLocn other                      = False -- All the rest
 198 \end{code}
 199
 200 %************************************************************************
 201 %*                                                                      *
 202 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 The following bits take ``raw'' Abstract~C, which may have all sorts of
 207 nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
 208 @CClosureInfos@ and code for switches are pulled out to the top level.
 209
 210 The various functions herein tend to produce
 211 \begin{enumerate}
 212 \item
 213 A {\em flattened} \tr{<something>} of interest for ``here'', and
 214 \item
 215 Some {\em unflattened} Abstract~C statements to be carried up to the
 216 top-level.  The only real reason (now) that it is unflattened is
 217 because it means the recursive flattening can be done in just one
 218 place rather than having to remember lots of places.
 219 \end{enumerate}
 220
 221 Care is taken to reduce the occurrence of forward references, while still
 222 keeping laziness a much as possible.  Essentially, this means that:
 223 \begin{itemize}
 224 \item
 225 {\em All} the top-level C statements resulting from flattening a
 226 particular AbsC statement (whether the latter is nested or not) appear
 227 before {\em any} of the code for a subsequent AbsC statement;
 228 \item
 229 but stuff nested within any AbsC statement comes
 230 out before the code for the statement itself.
 231 \end{itemize}
 232
 233 The ``stuff to be carried up'' always includes a label: a
 234 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
 235 @CCodeBlock@.  The latter turns into a C function, and is never
 236 actually produced by the code generator.  Rather it always starts life
 237 as a @CCodeBlock@ addressing mode; when such an addr mode is
 238 flattened, the ``tops'' stuff is a @CCodeBlock@.
 239
 240 \begin{code}
 241 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
 242
 243 flattenAbsC us abs_C
 244   = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
 245     here `mkAbsCStmts` tops }
 246 \end{code}
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsubsection{Flattening monadery}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 The flattener is monadised.  It's just a @UniqueSupply@.
 255
 256 \begin{code}
 257 type FlatM result =  UniqSupply -> result
 258
 259 initFlt :: UniqSupply -> FlatM a -> a
 260
 261 initFlt init_us m = m init_us
 262
 263 {-# INLINE thenFlt #-}
 264 {-# INLINE returnFlt #-}
 265
 266 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
 267
 268 thenFlt expr cont us
 269   = case (splitUniqSupply us)   of { (s1, s2) ->
 270     case (expr s1)              of { result ->
 271     cont result s2 }}
 272
 273 returnFlt :: a -> FlatM a
 274 returnFlt result us = result
 275
 276 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
 277
 278 mapFlt f []     = returnFlt []
 279 mapFlt f (x:xs)
 280   = f x         `thenFlt` \ r  ->
 281     mapFlt f xs `thenFlt` \ rs ->
 282     returnFlt (r:rs)
 283
 284 mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
 285
 286 mapAndUnzipFlt f [] = returnFlt ([],[])
 287 mapAndUnzipFlt f (x:xs)
 288   = f x                 `thenFlt` \ (r1,  r2)  ->
 289     mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
 290     returnFlt (r1:rs1, r2:rs2)
 291
 292 getUniqFlt :: FlatM Unique
 293 getUniqFlt us = uniqFromSupply us
 294
 295 getUniqsFlt :: FlatM [Unique]
 296 getUniqsFlt us = uniqsFromSupply us
 297 \end{code}
 298
 299 %************************************************************************
 300 %*                                                                      *
 301 \subsubsection{Flattening the top level}
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 \begin{code}
 306 flatAbsC :: AbstractC
 307          -> FlatM (AbstractC,   -- Stuff to put inline          [Both are fully
 308                    AbstractC)   -- Stuff to put at top level     flattened]
 309
 310 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
 311
 312 flatAbsC (AbsCStmts s1 s2)
 313   = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
 314     flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
 315     returnFlt (mkAbsCStmts inline_s1 inline_s2,
 316                mkAbsCStmts top_s1    top_s2)
 317
 318 flatAbsC (CClosureInfoAndCode cl_info entry)
 319   = flatAbsC entry              `thenFlt` \ (entry_heres, entry_tops) ->
 320     returnFlt (AbsCNop, mkAbstractCs [entry_tops,
 321        CClosureInfoAndCode cl_info entry_heres]
 322     )
 323
 324 flatAbsC (CCodeBlock lbl abs_C)
 325   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 326     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 327
 328 flatAbsC (CRetDirect uniq slow_code srt liveness)
 329   = flatAbsC slow_code          `thenFlt` \ (heres, tops) ->
 330     returnFlt (AbsCNop,
 331                 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
 332
 333 flatAbsC (CSwitch discrim alts deflt)
 334   = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 335     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 336     returnFlt (
 337       CSwitch discrim flat_alts flat_def_alt,
 338       mkAbstractCs (def_tops : flat_alts_tops)
 339     )
 340   where
 341     flat_alt (tag, absC)
 342       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 343         returnFlt ( (tag, alt_heres), alt_tops )
 344
 345 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
 346   |  is_dynamic                          -- Emit a typedef if its a dynamic call
 347      || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
 348   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
 349   where
 350     is_dynamic = isDynamicTarget target
 351
 352 flatAbsC stmt@(CSimultaneous abs_c)
 353   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 354     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 355     returnFlt (new_stmts_here, tops)
 356
 357 flatAbsC stmt@(CCheck macro amodes code)
 358   = flatAbsC code               `thenFlt` \ (code_here, code_tops) ->
 359     returnFlt (CCheck macro amodes code_here, code_tops)
 360
 361 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
 362 -- This is a HACK.
 363 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 364   | str == FSLIT("TICK_CTR")    = returnFlt (AbsCNop, stmt)
 365   | otherwise                   = returnFlt (stmt, AbsCNop)
 366
 367 -- Some statements need no flattening at all:
 368 flatAbsC stmt@(CMacroStmt macro amodes)          = returnFlt (stmt, AbsCNop)
 369 flatAbsC stmt@(CCallProfCCMacro str amodes)      = returnFlt (stmt, AbsCNop)
 370 flatAbsC stmt@(CAssign dest source)              = returnFlt (stmt, AbsCNop)
 371 flatAbsC stmt@(CJump target)                     = returnFlt (stmt, AbsCNop)
 372 flatAbsC stmt@(CFallThrough target)              = returnFlt (stmt, AbsCNop)
 373 flatAbsC stmt@(CReturn target return_info)       = returnFlt (stmt, AbsCNop)
 374 flatAbsC stmt@(CInitHdr a b cc sz)               = returnFlt (stmt, AbsCNop)
 375 flatAbsC stmt@(CMachOpStmt res mop args m_vols)  = returnFlt (stmt, AbsCNop)
 376 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
 377                                                  = returnFlt (stmt, AbsCNop)
 378 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
 379    = dscCOpStmt (filter non_void_amode results) op
 380                 (filter non_void_amode args) vol_regs
 381                                 `thenFlt` \ simpl ->
 382      case simpl of
 383         COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt"   -- make sure we don't loop!
 384         other           -> flatAbsC other
 385      {-
 386         A gruesome hack for printing the names of inline primops when they
 387         are used.
 388                                   oink other
 389      where
 390         oink xxx
 391             = getUniqFlt `thenFlt` \ uu ->
 392               flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
 393
 394         moo uu op_str
 395            = COpStmt
 396                 []
 397                 (StgFCallOp
 398                     (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
 399                                       defaultCCallConv (PlaySafe False)))
 400                     uu
 401                 )
 402                 [CReg VoidReg]
 403                 []
 404         mktxt op_str
 405             = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
 406      -}
 407
 408 flatAbsC (CSequential abcs)
 409   = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
 410     returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
 411
 412
 413 -- Some statements only make sense at the top level, so we always float
 414 -- them.  This probably isn't necessary.
 415 flatAbsC stmt@(CStaticClosure _ _ _ _)          = returnFlt (AbsCNop, stmt)
 416 flatAbsC stmt@(CClosureTbl _)                   = returnFlt (AbsCNop, stmt)
 417 flatAbsC stmt@(CSRT _ _)                        = returnFlt (AbsCNop, stmt)
 418 flatAbsC stmt@(CSRTDesc _ _ _ _ _)              = returnFlt (AbsCNop, stmt)
 419 flatAbsC stmt@(CBitmap _)                       = returnFlt (AbsCNop, stmt)
 420 flatAbsC stmt@(CCostCentreDecl _ _)             = returnFlt (AbsCNop, stmt)
 421 flatAbsC stmt@(CCostCentreStackDecl _)          = returnFlt (AbsCNop, stmt)
 422 flatAbsC stmt@(CSplitMarker)                    = returnFlt (AbsCNop, stmt)
 423 flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
 424 flatAbsC stmt@(CModuleInitBlock _ _ _)          = returnFlt (AbsCNop, stmt)
 425 \end{code}
 426
 427 \begin{code}
 428 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
 429 flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
 430 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
 431                           returnFlt (Just heres, tops)
 432 \end{code}
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection[flat-simultaneous]{Doing things simultaneously}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 \begin{code}
 441 doSimultaneously :: AbstractC -> FlatM AbstractC
 442 \end{code}
 443
 444 Generate code to perform the @CAssign@s and @COpStmt@s in the
 445 input simultaneously, using temporary variables when necessary.
 446
 447 We use the strongly-connected component algorithm, in which
 448         * the vertices are the statements
 449         * an edge goes from s1 to s2 iff
 450                 s1 assigns to something s2 uses
 451           that is, if s1 should *follow* s2 in the final order
 452
 453 \begin{code}
 454 type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
 455                                  -- for fast comparison
 456
 457 doSimultaneously abs_c
 458   = let
 459         enlisted = en_list abs_c
 460     in
 461     case enlisted of -- it's often just one stmt
 462       []  -> returnFlt AbsCNop
 463       [x] -> returnFlt x
 464       _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
 465
 466 -- en_list puts all the assignments in a list, filtering out Nops and
 467 -- assignments which do nothing
 468 en_list AbsCNop                               = []
 469 en_list (AbsCStmts a1 a2)                     = en_list a1 ++ en_list a2
 470 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
 471 en_list other                                 = [other]
 472
 473 sameAmode :: CAddrMode -> CAddrMode -> Bool
 474 -- ToDo: Move this function, or make CAddrMode an instance of Eq
 475 -- At the moment we put in just enough to catch the cases we want:
 476 --      the second (destination) argument is always a CVal.
 477 sameAmode (CReg r1)                  (CReg r2)               = r1 == r2
 478 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)            = r1 ==# r2
 479 sameAmode other1                     other2                  = False
 480
 481 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
 482 doSimultaneously1 vertices
 483   = let
 484         edges = [ (vertex, key1, edges_from stmt1)
 485                 | vertex@(key1, stmt1) <- vertices
 486                 ]
 487         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 488                                     stmt1 `should_follow` stmt2
 489                            ]
 490         components = stronglyConnComp edges
 491
 492         -- do_components deal with one strongly-connected component
 493                 -- Not cyclic, or singleton?  Just do it
 494         do_component (AcyclicSCC (n,abs_c))  = returnFlt abs_c
 495         do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
 496
 497                 -- Cyclic?  Then go via temporaries.  Pick one to
 498                 -- break the loop and try again with the rest.
 499         do_component (CyclicSCC ((n,first_stmt) : rest))
 500           = doSimultaneously1 rest      `thenFlt` \ abs_cs ->
 501             go_via_temps first_stmt     `thenFlt` \ (to_temps, from_temps) ->
 502             returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
 503
 504         go_via_temps (CAssign dest src)
 505           = getUniqFlt                  `thenFlt` \ uniq ->
 506             let
 507                 the_temp = CTemp uniq (getAmodeRep dest)
 508             in
 509             returnFlt (CAssign the_temp src, CAssign dest the_temp)
 510
 511         go_via_temps (COpStmt dests op srcs vol_regs)
 512           = getUniqsFlt                 `thenFlt` \ uniqs ->
 513             let
 514                 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 515             in
 516             returnFlt (COpStmt the_temps op srcs vol_regs,
 517                        mkAbstractCs (zipWith CAssign dests the_temps))
 518     in
 519     mapFlt do_component components `thenFlt` \ abs_cs ->
 520     returnFlt (mkAbstractCs abs_cs)
 521
 522   where
 523     should_follow :: AbstractC -> AbstractC -> Bool
 524     (CAssign dest1 _) `should_follow` (CAssign _ src2)
 525       = dest1 `conflictsWith` src2
 526     (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
 527       = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
 528     (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
 529       = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
 530     (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
 531       = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
 532 \end{code}
 533
 534 @conflictsWith@ tells whether an assignment to its first argument will
 535 screw up an access to its second.
 536
 537 \begin{code}
 538 conflictsWith :: CAddrMode -> CAddrMode -> Bool
 539 (CReg reg1)        `conflictsWith` (CReg reg2)          = reg1 == reg2
 540 (CReg reg)         `conflictsWith` (CVal reg_rel _)     = reg `regConflictsWithRR` reg_rel
 541 (CReg reg)         `conflictsWith` (CAddr reg_rel)      = reg `regConflictsWithRR` reg_rel
 542 (CTemp u1 _)       `conflictsWith` (CTemp u2 _)         = u1 == u2
 543 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
 544   = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
 545
 546 other1            `conflictsWith` other2                = False
 547 -- CAddr and literals are impossible on the LHS of an assignment
 548
 549 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 550
 551 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1)    = True
 552 regConflictsWithRR Sp   (SpRel _)       = True
 553 regConflictsWithRR Hp   (HpRel _)       = True
 554 regConflictsWithRR _    _               = False
 555
 556 rrConflictsWithRR :: Int -> Int                 -- Sizes of two things
 557                   -> RegRelative -> RegRelative -- The two amodes
 558                   -> Bool
 559
 560 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
 561   where
 562     s1 = iUnbox s1b
 563     s2 = iUnbox s2b
 564
 565     rr (SpRel o1)    (SpRel o2)
 566         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 567         | s1 ==# (_ILIT 1)  && s2 ==# (_ILIT 1) = o1 ==# o2
 568         | otherwise          = (o1 +# s1) >=# o2  &&
 569                                (o2 +# s2) >=# o1
 570
 571     rr (NodeRel o1)      (NodeRel o2)
 572         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 573         | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
 574         | otherwise          = True             -- Give up
 575
 576     rr (HpRel _)         (HpRel _)    = True    -- Give up (ToDo)
 577
 578     rr other1            other2       = False
 579 \end{code}
 580
 581 %************************************************************************
 582 %*                                                                      *
 583 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
 584 %*                                                                      *
 585 %************************************************************************
 586
 587 \begin{code}
 588
 589 -- We begin with some helper functions.  The main Dude here is
 590 -- dscCOpStmt, defined a little further down.
 591
 592 ------------------------------------------------------------------------------
 593
 594 -- Assumes no volatiles
 595 -- Creates
 596 --     res = arg >> (bits-per-word / 2)   when little-endian
 597 -- or
 598 --     res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
 599 --
 600 -- In other words, if arg had been stored in memory, makes res the
 601 -- halfword of arg which would have had the higher address.  This is
 602 -- why it needs to take into account endianness.
 603 --
 604 mkHalfWord_HIADDR res arg
 605    = mkTemp WordRep                     `thenFlt` \ t_hw_mask1 ->
 606      mkTemp WordRep                     `thenFlt` \ t_hw_mask2 ->
 607      let
 608          hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
 609
 610          a_hw_mask1
 611             = CMachOpStmt t_hw_mask1
 612                           MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
 613          a_hw_mask2
 614             = CMachOpStmt t_hw_mask2
 615                           MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
 616          final
 617 #        if WORDS_BIGENDIAN
 618             = CSequential [ a_hw_mask1, a_hw_mask2,
 619                  CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
 620               ]
 621 #        else
 622             = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
 623 #        endif
 624      in
 625          returnFlt final
 626
 627
 628 mkTemp :: PrimRep -> FlatM CAddrMode
 629 mkTemp rep
 630    = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
 631
 632 mkTemps = mapFlt mkTemp
 633
 634 -- Sigh.  This is done in 3 seperate places.  Should be
 635 -- commoned up (here, in pprAbsC of COpStmt, and presumably
 636 -- somewhere in the NCG).
 637 non_void_amode amode
 638    = case getAmodeRep amode of
 639         VoidRep -> False
 640         k       -> True
 641
 642 -- Helpers for translating various minor variants of array indexing.
 643
 644 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 645 mkDerefOff rep base off
 646    = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
 647
 648 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 649 mkNoDerefOff rep base off
 650    = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
 651
 652
 653 -- Generates an address as follows
 654 --    base + sizeof(machine_word)*offw + sizeof(rep)*idx
 655 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
 656 mk_OSBI_addr offw rep base idx
 657    = CIndex (CAddr (CIndex base idx rep))
 658             (CLit (mkMachWord (fromIntegral offw)))
 659             PtrRep
 660
 661 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
 662 mk_OSBI_ref offw rep base idx
 663    = CVal (mk_OSBI_addr offw rep base idx) rep
 664
 665
 666 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
 667    = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
 668
 669 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
 670    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 671
 672 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
 673    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 674
 675 doReadPtrArrayOp res addr idx
 676    = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
 677
 678
 679 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
 680    = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
 681
 682 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
 683    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
 684
 685 doWritePtrArrayOp addr idx val
 686    = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
 687
 688
 689
 690 mkBasicIndexedRead offw Nothing read_rep res base idx
 691    = returnFlt (
 692         CAssign res (mk_OSBI_ref offw read_rep base idx)
 693      )
 694 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
 695    = mkTemp read_rep                    `thenFlt` \ tmp ->
 696      (returnFlt . CSequential) [
 697         CAssign tmp (mk_OSBI_ref offw read_rep base idx),
 698         CMachOpStmt res cast_to_mop [tmp] Nothing
 699      ]
 700
 701 mkBasicIndexedWrite offw Nothing write_rep base idx val
 702    = returnFlt (
 703         CAssign (mk_OSBI_ref offw write_rep base idx) val
 704      )
 705 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
 706    = mkTemp write_rep                   `thenFlt` \ tmp ->
 707      (returnFlt . CSequential) [
 708         CMachOpStmt tmp cast_to_mop [val] Nothing,
 709         CAssign (mk_OSBI_ref offw write_rep base idx) tmp
 710      ]
 711
 712
 713 -- Simple dyadic op but one for which we need to cast first arg to
 714 -- be sure of correctness
 715 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
 716    = mkTemp cast_arg1_to                `thenFlt` \ arg1casted ->
 717      (returnFlt . CSequential) [
 718         CAssign arg1casted arg1,
 719         CMachOpStmt res mop [arg1casted,arg2]
 720            (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 721      ]
 722
 723 -- IA64 mangler doesn't place tables next to code
 724 tablesNextToCode :: Bool
 725 #ifdef ia64_TARGET_ARCH
 726 tablesNextToCode = False
 727 #else
 728 tablesNextToCode = not opt_Unregisterised
 729 #endif
 730
 731 ------------------------------------------------------------------------------
 732
 733 -- This is the main top-level desugarer PrimOps into MachOps.  First we
 734 -- handle various awkward cases specially.  The remaining easy cases are
 735 -- then handled by translateOp, defined below.
 736
 737
 738 dscCOpStmt :: [CAddrMode]       -- Results
 739            -> PrimOp
 740            -> [CAddrMode]       -- Arguments
 741            -> [MagicId]         -- Potentially volatile/live registers
 742                                 -- (to save/restore around the op)
 743            -> FlatM AbstractC
 744
 745
 746 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
 747 {-
 748    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 749    C, and without needing any comparisons.  This may not be the
 750    fastest way to do it - if you have better code, please send it! --SDM
 751
 752    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 753
 754    We currently don't make use of the r value if c is != 0 (i.e.
 755    overflow), we just convert to big integers and try again.  This
 756    could be improved by making r and c the correct values for
 757    plugging into a new J#.
 758
 759    { r = ((I_)(a)) + ((I_)(b));                                 \
 760      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
 761          >> (BITS_IN (I_) - 1);                                 \
 762    }
 763    Wading through the mass of bracketry, it seems to reduce to:
 764    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
 765
 766    SSA-form:
 767    t1 = a^b
 768    t2 = ~t1
 769    t3 = a^r
 770    t4 = t2 & t3
 771    c  = t4 >>unsigned BITS_IN(I_)-1
 772 -}
 773    = mkTemps [IntRep,IntRep,IntRep,IntRep]      `thenFlt` \ [t1,t2,t3,t4] ->
 774      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 775      (returnFlt . CSequential) [
 776         CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
 777         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 778         CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
 779         CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
 780         CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
 781         CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
 782      ]
 783
 784
 785 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
 786 {- Similarly:
 787    #define subIntCzh(r,c,a,b)                                   \
 788    { r = ((I_)(a)) - ((I_)(b));                                 \
 789      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
 790          >> (BITS_IN (I_) - 1);                                 \
 791    }
 792
 793    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
 794
 795    t1 = a^b
 796    t2 = a^r
 797    t3 = t1 & t2
 798    c  = t3 >>unsigned BITS_IN(I_)-1
 799 -}
 800    = mkTemps [IntRep,IntRep,IntRep]             `thenFlt` \ [t1,t2,t3] ->
 801      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 802      (returnFlt . CSequential) [
 803         CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
 804         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 805         CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
 806         CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
 807         CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
 808      ]
 809
 810
 811 -- #define parzh(r,node) r = 1
 812 dscCOpStmt [res] ParOp [arg] vols
 813    = returnFlt
 814         (CAssign res (CLit (mkMachInt 1)))
 815
 816 -- #define readMutVarzh(r,a)     r=(P_)(((StgMutVar *)(a))->var)
 817 dscCOpStmt [res] ReadMutVarOp [mutv] vols
 818    = returnFlt
 819         (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
 820
 821 -- #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 822 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
 823    = returnFlt
 824         (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
 825
 826
 827 -- #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 828 -- #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 829 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
 830    = returnFlt
 831         (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
 832
 833 -- #define writeForeignObjzh(res,datum) \
 834 --    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 835 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
 836    = returnFlt
 837         (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
 838
 839
 840 -- #define sizzeofByteArrayzh(r,a) \
 841 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 842 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 843    = mkTemp WordRep                     `thenFlt` \ w ->
 844      (returnFlt . CSequential) [
 845         CAssign w (mkDerefOff WordRep arg fixedHdrSize),
 846         CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols),
 847         CAssign res w
 848      ]
 849
 850 -- #define sizzeofMutableByteArrayzh(r,a) \
 851 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
 852 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
 853    = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 854
 855
 856 -- #define touchzh(o)                  /* nothing */
 857 dscCOpStmt [] TouchOp [arg] vols
 858    = returnFlt AbsCNop
 859
 860 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 861 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
 862    = mkTemp PtrRep                      `thenFlt` \ ptr ->
 863      (returnFlt . CSequential) [
 864          CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
 865          CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
 866          CAssign res ptr
 867      ]
 868
 869 -- #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 870 dscCOpStmt [res] StableNameToIntOp [arg] vols
 871    = returnFlt
 872         (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
 873
 874 -- #define eqStableNamezh(r,sn1,sn2)                                    \
 875 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 876 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
 877    = mkTemps [WordRep, WordRep]         `thenFlt` \ [sn1,sn2] ->
 878      (returnFlt . CSequential) [
 879         CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
 880         CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
 881         CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
 882      ]
 883
 884 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
 885    = mkTemps [WordRep, WordRep]         `thenFlt` \ [w1,w2] ->
 886      (returnFlt . CSequential) [
 887         CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
 888         CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
 889         CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
 890      ]
 891
 892 -- #define addrToHValuezh(r,a) r=(P_)a
 893 dscCOpStmt [res] AddrToHValueOp [arg] vols
 894    = returnFlt
 895         (CAssign res arg)
 896
 897 -- #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 898 --
 899 --   In the unregisterised case, we don't attempt to compute the location
 900 --   of the tag halfword, just a macro. For this build, fixing on layout
 901 --   info has only got drawbacks.
 902 --
 903 --   Should this arrangement deeply offend you for some reason, code which
 904 --   computes the offset can be found below also.
 905 --      -- sof 3/02
 906 --
 907 dscCOpStmt [res] DataToTagOp [arg] vols
 908    | not tablesNextToCode
 909    = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
 910    | otherwise
 911    = mkTemps [PtrRep, WordRep]          `thenFlt` \ [t_infoptr, t_theword] ->
 912      mkHalfWord_HIADDR res t_theword    `thenFlt` \ select_ops ->
 913      (returnFlt . CSequential) [
 914         CAssign t_infoptr (mkDerefOff PtrRep arg 0),
 915          {-
 916            Get at the tag within the info table; two cases to consider:
 917
 918               - reversed info tables next to the entry point code;
 919                 one word above the end of the info table (which is
 920                 what t_infoptr is really pointing to).
 921               - info tables with their entry points stored somewhere else,
 922                 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
 923                 world operates.
 924
 925                 The t_infoptr points to the start of the info table, so add
 926                 the length of the info table & subtract one word.
 927          -}
 928         CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
 929 {- UNUSED - see above comment.
 930                                      (if opt_Unregisterised then
 931                                          (fixedItblSize - 1)
 932                                       else (-1))),
 933 -}
 934         select_ops
 935      ]
 936
 937
 938 {- Freezing arrays-of-ptrs requires changing an info table, for the
 939    benefit of the generational collector.  It needs to scavenge mutable
 940    objects, even if they are in old space.  When they become immutable,
 941    they can be removed from this scavenge list.  -}
 942
 943 -- #define unsafeFreezzeArrayzh(r,a)                                    \
 944 --      {                                                               \
 945 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 946 --      r = a;                                                          \
 947 --      }
 948 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
 949    = (returnFlt . CSequential) [
 950         CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
 951         CAssign res arg
 952      ]
 953
 954 -- #define unsafeFreezzeByteArrayzh(r,a)        r=(a)
 955 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
 956    = returnFlt
 957         (CAssign res arg)
 958
 959 -- This ought to be trivial, but it's difficult to insert the casts
 960 -- required to keep the C compiler happy.
 961 dscCOpStmt [r] AddrRemOp [a1,a2] vols
 962    = mkTemp WordRep                     `thenFlt` \ a1casted ->
 963      (returnFlt . CSequential) [
 964         CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
 965         CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
 966      ]
 967
 968 -- not handled by translateOp because they need casts
 969 dscCOpStmt [r] SllOp [a1,a2] vols
 970    = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
 971 dscCOpStmt [r] SrlOp [a1,a2] vols
 972    = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
 973
 974 dscCOpStmt [r] ISllOp [a1,a2] vols
 975    = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
 976 dscCOpStmt [r] ISrlOp [a1,a2] vols
 977    = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
 978 dscCOpStmt [r] ISraOp [a1,a2] vols
 979    = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
 980
 981 -- Reading/writing pointer arrays
 982
 983 dscCOpStmt [r] ReadArrayOp  [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 984 dscCOpStmt [r] IndexArrayOp [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 985 dscCOpStmt []  WriteArrayOp [obj,ix,v] vols  = doWritePtrArrayOp obj ix v
 986
 987 -- IndexXXXoffForeignObj
 988
 989 dscCOpStmt [r] IndexOffForeignObjOp_Char      [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
 990 dscCOpStmt [r] IndexOffForeignObjOp_WideChar  [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
 991 dscCOpStmt [r] IndexOffForeignObjOp_Int       [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
 992 dscCOpStmt [r] IndexOffForeignObjOp_Word      [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
 993 dscCOpStmt [r] IndexOffForeignObjOp_Addr      [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
 994 dscCOpStmt [r] IndexOffForeignObjOp_Float     [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
 995 dscCOpStmt [r] IndexOffForeignObjOp_Double    [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
 996 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
 997
 998 dscCOpStmt [r] IndexOffForeignObjOp_Int8      [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep  r a i
 999 dscCOpStmt [r] IndexOffForeignObjOp_Int16     [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
1000 dscCOpStmt [r] IndexOffForeignObjOp_Int32     [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
1001 dscCOpStmt [r] IndexOffForeignObjOp_Int64     [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
1002
1003 dscCOpStmt [r] IndexOffForeignObjOp_Word8     [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep  r a i
1004 dscCOpStmt [r] IndexOffForeignObjOp_Word16    [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1005 dscCOpStmt [r] IndexOffForeignObjOp_Word32    [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1006 dscCOpStmt [r] IndexOffForeignObjOp_Word64    [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1007
1008 -- IndexXXXoffAddr
1009
1010 dscCOpStmt [r] IndexOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1011 dscCOpStmt [r] IndexOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1012 dscCOpStmt [r] IndexOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1013 dscCOpStmt [r] IndexOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1014 dscCOpStmt [r] IndexOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1015 dscCOpStmt [r] IndexOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1016 dscCOpStmt [r] IndexOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1017 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1018
1019 dscCOpStmt [r] IndexOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1020 dscCOpStmt [r] IndexOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1021 dscCOpStmt [r] IndexOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1022 dscCOpStmt [r] IndexOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1023
1024 dscCOpStmt [r] IndexOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1025 dscCOpStmt [r] IndexOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1026 dscCOpStmt [r] IndexOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1027 dscCOpStmt [r] IndexOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1028
1029 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1030
1031 dscCOpStmt [r] ReadOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1032 dscCOpStmt [r] ReadOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1033 dscCOpStmt [r] ReadOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1034 dscCOpStmt [r] ReadOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1035 dscCOpStmt [r] ReadOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1036 dscCOpStmt [r] ReadOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1037 dscCOpStmt [r] ReadOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1038 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1039
1040 dscCOpStmt [r] ReadOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1041 dscCOpStmt [r] ReadOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1042 dscCOpStmt [r] ReadOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1043 dscCOpStmt [r] ReadOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1044
1045 dscCOpStmt [r] ReadOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1046 dscCOpStmt [r] ReadOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1047 dscCOpStmt [r] ReadOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1048 dscCOpStmt [r] ReadOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1049
1050 -- IndexXXXArray
1051
1052 dscCOpStmt [r] IndexByteArrayOp_Char      [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1053 dscCOpStmt [r] IndexByteArrayOp_WideChar  [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1054 dscCOpStmt [r] IndexByteArrayOp_Int       [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1055 dscCOpStmt [r] IndexByteArrayOp_Word      [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1056 dscCOpStmt [r] IndexByteArrayOp_Addr      [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1057 dscCOpStmt [r] IndexByteArrayOp_Float     [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1058 dscCOpStmt [r] IndexByteArrayOp_Double    [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1059 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1060
1061 dscCOpStmt [r] IndexByteArrayOp_Int8      [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1062 dscCOpStmt [r] IndexByteArrayOp_Int16     [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1063 dscCOpStmt [r] IndexByteArrayOp_Int32     [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1064 dscCOpStmt [r] IndexByteArrayOp_Int64     [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1065
1066 dscCOpStmt [r] IndexByteArrayOp_Word8     [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1067 dscCOpStmt [r] IndexByteArrayOp_Word16    [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1068 dscCOpStmt [r] IndexByteArrayOp_Word32    [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1069 dscCOpStmt [r] IndexByteArrayOp_Word64    [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1070
1071 -- ReadXXXArray, identical to IndexXXXArray.
1072
1073 dscCOpStmt [r] ReadByteArrayOp_Char       [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1074 dscCOpStmt [r] ReadByteArrayOp_WideChar   [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1075 dscCOpStmt [r] ReadByteArrayOp_Int        [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1076 dscCOpStmt [r] ReadByteArrayOp_Word       [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1077 dscCOpStmt [r] ReadByteArrayOp_Addr       [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1078 dscCOpStmt [r] ReadByteArrayOp_Float      [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1079 dscCOpStmt [r] ReadByteArrayOp_Double     [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1080 dscCOpStmt [r] ReadByteArrayOp_StablePtr  [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1081
1082 dscCOpStmt [r] ReadByteArrayOp_Int8       [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1083 dscCOpStmt [r] ReadByteArrayOp_Int16      [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1084 dscCOpStmt [r] ReadByteArrayOp_Int32      [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1085 dscCOpStmt [r] ReadByteArrayOp_Int64      [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1086
1087 dscCOpStmt [r] ReadByteArrayOp_Word8      [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1088 dscCOpStmt [r] ReadByteArrayOp_Word16     [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1089 dscCOpStmt [r] ReadByteArrayOp_Word32     [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1090 dscCOpStmt [r] ReadByteArrayOp_Word64     [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1091
1092 -- WriteXXXoffAddr
1093
1094 dscCOpStmt [] WriteOffAddrOp_Char       [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1095 dscCOpStmt [] WriteOffAddrOp_WideChar   [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1096 dscCOpStmt [] WriteOffAddrOp_Int        [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1097 dscCOpStmt [] WriteOffAddrOp_Word       [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1098 dscCOpStmt [] WriteOffAddrOp_Addr       [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1099 dscCOpStmt [] WriteOffAddrOp_Float      [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1100 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
1101 dscCOpStmt [] WriteOffAddrOp_Double     [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1102 dscCOpStmt [] WriteOffAddrOp_StablePtr  [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1103
1104 dscCOpStmt [] WriteOffAddrOp_Int8       [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep  a i x
1105 dscCOpStmt [] WriteOffAddrOp_Int16      [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1106 dscCOpStmt [] WriteOffAddrOp_Int32      [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1107 dscCOpStmt [] WriteOffAddrOp_Int64      [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1108
1109 dscCOpStmt [] WriteOffAddrOp_Word8      [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep  a i x
1110 dscCOpStmt [] WriteOffAddrOp_Word16     [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1111 dscCOpStmt [] WriteOffAddrOp_Word32     [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1112 dscCOpStmt [] WriteOffAddrOp_Word64     [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1113
1114 -- WriteXXXArray
1115
1116 dscCOpStmt [] WriteByteArrayOp_Char      [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1117 dscCOpStmt [] WriteByteArrayOp_WideChar  [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1118 dscCOpStmt [] WriteByteArrayOp_Int       [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1119 dscCOpStmt [] WriteByteArrayOp_Word      [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1120 dscCOpStmt [] WriteByteArrayOp_Addr      [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1121 dscCOpStmt [] WriteByteArrayOp_Float     [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1122 dscCOpStmt [] WriteByteArrayOp_Double    [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1123 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1124
1125 dscCOpStmt [] WriteByteArrayOp_Int8      [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep  a i x
1126 dscCOpStmt [] WriteByteArrayOp_Int16     [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep  a i x
1127 dscCOpStmt [] WriteByteArrayOp_Int32     [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep  a i x
1128 dscCOpStmt [] WriteByteArrayOp_Int64     [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep  a i x
1129
1130 dscCOpStmt [] WriteByteArrayOp_Word8     [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep  a i x
1131 dscCOpStmt [] WriteByteArrayOp_Word16    [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep  a i x
1132 dscCOpStmt [] WriteByteArrayOp_Word32    [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep  a i x
1133 dscCOpStmt [] WriteByteArrayOp_Word64    [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep  a i x
1134
1135
1136 -- Handle all others as simply as possible.
1137 dscCOpStmt ress op args vols
1138    = case translateOp ress op args of
1139         Nothing
1140            -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1141         Just (maybe_res, mop, args)
1142            -> returnFlt (
1143                  CMachOpStmt maybe_res mop args
1144                     (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1145               )
1146
1147 -- Native word signless ops
1148
1149 translateOp [r] IntAddOp       [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1150 translateOp [r] IntSubOp       [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1151 translateOp [r] WordAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1152 translateOp [r] WordSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1153 translateOp [r] AddrAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1154 translateOp [r] AddrSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1155
1156 translateOp [r] IntEqOp        [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1157 translateOp [r] IntNeOp        [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1158 translateOp [r] WordEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1159 translateOp [r] WordNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1160 translateOp [r] AddrEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1161 translateOp [r] AddrNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1162
1163 translateOp [r] AndOp          [a1,a2] = Just (r, MO_Nat_And,        [a1,a2])
1164 translateOp [r] OrOp           [a1,a2] = Just (r, MO_Nat_Or,         [a1,a2])
1165 translateOp [r] XorOp          [a1,a2] = Just (r, MO_Nat_Xor,        [a1,a2])
1166 translateOp [r] NotOp          [a1]    = Just (r, MO_Nat_Not,        [a1])
1167
1168 -- Native word signed ops
1169
1170 translateOp [r] IntMulOp       [a1,a2] = Just (r, MO_NatS_Mul,       [a1,a2])
1171 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1172 translateOp [r] IntQuotOp      [a1,a2] = Just (r, MO_NatS_Quot,      [a1,a2])
1173 translateOp [r] IntRemOp       [a1,a2] = Just (r, MO_NatS_Rem,       [a1,a2])
1174 translateOp [r] IntNegOp       [a1]    = Just (r, MO_NatS_Neg,       [a1])
1175
1176 translateOp [r] IntGeOp        [a1,a2] = Just (r, MO_NatS_Ge,        [a1,a2])
1177 translateOp [r] IntLeOp        [a1,a2] = Just (r, MO_NatS_Le,        [a1,a2])
1178 translateOp [r] IntGtOp        [a1,a2] = Just (r, MO_NatS_Gt,        [a1,a2])
1179 translateOp [r] IntLtOp        [a1,a2] = Just (r, MO_NatS_Lt,        [a1,a2])
1180
1181
1182 -- Native word unsigned ops
1183
1184 translateOp [r] WordGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1185 translateOp [r] WordLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1186 translateOp [r] WordGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1187 translateOp [r] WordLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1188
1189 translateOp [r] WordMulOp      [a1,a2] = Just (r, MO_NatU_Mul,       [a1,a2])
1190 translateOp [r] WordQuotOp     [a1,a2] = Just (r, MO_NatU_Quot,      [a1,a2])
1191 translateOp [r] WordRemOp      [a1,a2] = Just (r, MO_NatU_Rem,       [a1,a2])
1192
1193 translateOp [r] AddrGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1194 translateOp [r] AddrLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1195 translateOp [r] AddrGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1196 translateOp [r] AddrLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1197
1198 -- 32-bit unsigned ops
1199
1200 translateOp [r] CharEqOp       [a1,a2] = Just (r, MO_32U_Eq,        [a1,a2])
1201 translateOp [r] CharNeOp       [a1,a2] = Just (r, MO_32U_Ne,        [a1,a2])
1202 translateOp [r] CharGeOp       [a1,a2] = Just (r, MO_32U_Ge,        [a1,a2])
1203 translateOp [r] CharLeOp       [a1,a2] = Just (r, MO_32U_Le,        [a1,a2])
1204 translateOp [r] CharGtOp       [a1,a2] = Just (r, MO_32U_Gt,        [a1,a2])
1205 translateOp [r] CharLtOp       [a1,a2] = Just (r, MO_32U_Lt,        [a1,a2])
1206
1207 -- Double ops
1208
1209 translateOp [r] DoubleEqOp     [a1,a2] = Just (r, MO_Dbl_Eq,      [a1,a2])
1210 translateOp [r] DoubleNeOp     [a1,a2] = Just (r, MO_Dbl_Ne,      [a1,a2])
1211 translateOp [r] DoubleGeOp     [a1,a2] = Just (r, MO_Dbl_Ge,      [a1,a2])
1212 translateOp [r] DoubleLeOp     [a1,a2] = Just (r, MO_Dbl_Le,      [a1,a2])
1213 translateOp [r] DoubleGtOp     [a1,a2] = Just (r, MO_Dbl_Gt,      [a1,a2])
1214 translateOp [r] DoubleLtOp     [a1,a2] = Just (r, MO_Dbl_Lt,      [a1,a2])
1215
1216 translateOp [r] DoubleAddOp    [a1,a2] = Just (r, MO_Dbl_Add,    [a1,a2])
1217 translateOp [r] DoubleSubOp    [a1,a2] = Just (r, MO_Dbl_Sub,    [a1,a2])
1218 translateOp [r] DoubleMulOp    [a1,a2] = Just (r, MO_Dbl_Mul,    [a1,a2])
1219 translateOp [r] DoubleDivOp    [a1,a2] = Just (r, MO_Dbl_Div,    [a1,a2])
1220 translateOp [r] DoublePowerOp  [a1,a2] = Just (r, MO_Dbl_Pwr,    [a1,a2])
1221
1222 translateOp [r] DoubleSinOp    [a1]    = Just (r, MO_Dbl_Sin,    [a1])
1223 translateOp [r] DoubleCosOp    [a1]    = Just (r, MO_Dbl_Cos,    [a1])
1224 translateOp [r] DoubleTanOp    [a1]    = Just (r, MO_Dbl_Tan,    [a1])
1225 translateOp [r] DoubleSinhOp   [a1]    = Just (r, MO_Dbl_Sinh,   [a1])
1226 translateOp [r] DoubleCoshOp   [a1]    = Just (r, MO_Dbl_Cosh,   [a1])
1227 translateOp [r] DoubleTanhOp   [a1]    = Just (r, MO_Dbl_Tanh,   [a1])
1228 translateOp [r] DoubleAsinOp   [a1]    = Just (r, MO_Dbl_Asin,    [a1])
1229 translateOp [r] DoubleAcosOp   [a1]    = Just (r, MO_Dbl_Acos,    [a1])
1230 translateOp [r] DoubleAtanOp   [a1]    = Just (r, MO_Dbl_Atan,    [a1])
1231 translateOp [r] DoubleLogOp    [a1]    = Just (r, MO_Dbl_Log,    [a1])
1232 translateOp [r] DoubleExpOp    [a1]    = Just (r, MO_Dbl_Exp,    [a1])
1233 translateOp [r] DoubleSqrtOp   [a1]    = Just (r, MO_Dbl_Sqrt,    [a1])
1234 translateOp [r] DoubleNegOp    [a1]    = Just (r, MO_Dbl_Neg,    [a1])
1235
1236 -- Float ops
1237
1238 translateOp [r] FloatEqOp     [a1,a2] = Just (r, MO_Flt_Eq,      [a1,a2])
1239 translateOp [r] FloatNeOp     [a1,a2] = Just (r, MO_Flt_Ne,      [a1,a2])
1240 translateOp [r] FloatGeOp     [a1,a2] = Just (r, MO_Flt_Ge,      [a1,a2])
1241 translateOp [r] FloatLeOp     [a1,a2] = Just (r, MO_Flt_Le,      [a1,a2])
1242 translateOp [r] FloatGtOp     [a1,a2] = Just (r, MO_Flt_Gt,      [a1,a2])
1243 translateOp [r] FloatLtOp     [a1,a2] = Just (r, MO_Flt_Lt,      [a1,a2])
1244
1245 translateOp [r] FloatAddOp    [a1,a2] = Just (r, MO_Flt_Add,    [a1,a2])
1246 translateOp [r] FloatSubOp    [a1,a2] = Just (r, MO_Flt_Sub,    [a1,a2])
1247 translateOp [r] FloatMulOp    [a1,a2] = Just (r, MO_Flt_Mul,    [a1,a2])
1248 translateOp [r] FloatDivOp    [a1,a2] = Just (r, MO_Flt_Div,    [a1,a2])
1249 translateOp [r] FloatPowerOp  [a1,a2] = Just (r, MO_Flt_Pwr,    [a1,a2])
1250
1251 translateOp [r] FloatSinOp    [a1]    = Just (r, MO_Flt_Sin,    [a1])
1252 translateOp [r] FloatCosOp    [a1]    = Just (r, MO_Flt_Cos,    [a1])
1253 translateOp [r] FloatTanOp    [a1]    = Just (r, MO_Flt_Tan,    [a1])
1254 translateOp [r] FloatSinhOp   [a1]    = Just (r, MO_Flt_Sinh,   [a1])
1255 translateOp [r] FloatCoshOp   [a1]    = Just (r, MO_Flt_Cosh,   [a1])
1256 translateOp [r] FloatTanhOp   [a1]    = Just (r, MO_Flt_Tanh,   [a1])
1257 translateOp [r] FloatAsinOp   [a1]    = Just (r, MO_Flt_Asin,    [a1])
1258 translateOp [r] FloatAcosOp   [a1]    = Just (r, MO_Flt_Acos,    [a1])
1259 translateOp [r] FloatAtanOp   [a1]    = Just (r, MO_Flt_Atan,    [a1])
1260 translateOp [r] FloatLogOp    [a1]    = Just (r, MO_Flt_Log,    [a1])
1261 translateOp [r] FloatExpOp    [a1]    = Just (r, MO_Flt_Exp,    [a1])
1262 translateOp [r] FloatSqrtOp   [a1]    = Just (r, MO_Flt_Sqrt,    [a1])
1263 translateOp [r] FloatNegOp    [a1]    = Just (r, MO_Flt_Neg,    [a1])
1264
1265 -- Conversions
1266
1267 translateOp [r] Int2DoubleOp   [a1]   = Just (r, MO_NatS_to_Dbl,   [a1])
1268 translateOp [r] Double2IntOp   [a1]   = Just (r, MO_Dbl_to_NatS,   [a1])
1269
1270 translateOp [r] Int2FloatOp    [a1]   = Just (r, MO_NatS_to_Flt,   [a1])
1271 translateOp [r] Float2IntOp    [a1]   = Just (r, MO_Flt_to_NatS,   [a1])
1272
1273 translateOp [r] Float2DoubleOp [a1]   = Just (r, MO_Flt_to_Dbl,    [a1])
1274 translateOp [r] Double2FloatOp [a1]   = Just (r, MO_Dbl_to_Flt,    [a1])
1275
1276 translateOp [r] Int2WordOp     [a1]   = Just (r, MO_NatS_to_NatU,  [a1])
1277 translateOp [r] Word2IntOp     [a1]   = Just (r, MO_NatU_to_NatS,  [a1])
1278
1279 translateOp [r] Int2AddrOp     [a1]   = Just (r, MO_NatS_to_NatP,  [a1])
1280 translateOp [r] Addr2IntOp     [a1]   = Just (r, MO_NatP_to_NatS,  [a1])
1281
1282 translateOp [r] OrdOp          [a1]   = Just (r, MO_32U_to_NatS,   [a1])
1283 translateOp [r] ChrOp          [a1]   = Just (r, MO_NatS_to_32U,   [a1])
1284
1285 translateOp [r] Narrow8IntOp   [a1]   = Just (r, MO_8S_to_NatS,    [a1])
1286 translateOp [r] Narrow16IntOp  [a1]   = Just (r, MO_16S_to_NatS,   [a1])
1287 translateOp [r] Narrow32IntOp  [a1]   = Just (r, MO_32S_to_NatS,   [a1])
1288
1289 translateOp [r] Narrow8WordOp   [a1]  = Just (r, MO_8U_to_NatU,    [a1])
1290 translateOp [r] Narrow16WordOp  [a1]  = Just (r, MO_16U_to_NatU,   [a1])
1291 translateOp [r] Narrow32WordOp  [a1]  = Just (r, MO_32U_to_NatU,   [a1])
1292
1293 -- Word comparisons masquerading as more exotic things.
1294
1295 translateOp [r] SameMutVarOp   [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1296 translateOp [r] SameMVarOp     [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1297 translateOp [r] SameMutableArrayOp  [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1298 translateOp [r] SameMutableByteArrayOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1299 translateOp [r] EqForeignObj [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1300 translateOp [r] EqStablePtrOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1301
1302 translateOp _ _ _ = Nothing
1303
1304 \end{code}