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