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