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