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 )
  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, maybeToList )
  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 \end{code}
 155
 156 %************************************************************************
 157 %*                                                                      *
 158 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 159 %*                                                                      *
 160 %************************************************************************
 161
 162 See also the return conventions for unboxed things; currently living
 163 in @CgCon@ (next to the constructor return conventions).
 164
 165 ToDo: tiny tweaking may be in order
 166 \begin{code}
 167 getAmodeRep :: CAddrMode -> PrimRep
 168
 169 getAmodeRep (CVal _ kind)                   = kind
 170 getAmodeRep (CAddr _)                       = PtrRep
 171 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 172 getAmodeRep (CTemp uniq kind)               = kind
 173 getAmodeRep (CLbl _ kind)                   = kind
 174 getAmodeRep (CCharLike _)                   = PtrRep
 175 getAmodeRep (CIntLike _)                    = PtrRep
 176 getAmodeRep (CLit lit)                      = literalPrimRep lit
 177 getAmodeRep (CMacroExpr kind _ _)           = kind
 178 getAmodeRep (CJoinPoint _)                  = panic "getAmodeRep:CJoinPoint"
 179 getAmodeRep (CMem rep addr)                 = rep
 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))
 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
 594 ------------------------------------------------------------------------------
 595
 596 -- Assumes no volatiles
 597 -- Creates
 598 --     res = arg >> (bits-per-word / 2)   when little-endian
 599 -- or
 600 --     res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
 601 --
 602 -- In other words, if arg had been stored in memory, makes res the
 603 -- halfword of arg which would have had the higher address.  This is
 604 -- why it needs to take into account endianness.
 605 --
 606 mkHalfWord_HIADDR res arg
 607    = mkTemp IntRep                      `thenFlt` \ t_hw_shift ->
 608      mkTemp WordRep                     `thenFlt` \ t_hw_mask1 ->
 609      mkTemp WordRep                     `thenFlt` \ t_hw_mask2 ->
 610      let a_hw_shift
 611             = CMachOpStmt (Just t_hw_shift)
 612                           MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
 613          a_hw_mask1
 614             = CMachOpStmt (Just t_hw_mask1)
 615                           MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
 616          a_hw_mask2
 617             = CMachOpStmt (Just t_hw_mask2)
 618                           MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
 619          final
 620 #        if WORDS_BIGENDIAN
 621             = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2,
 622                  CMachOpStmt (Just res) MO_Nat_And [arg, t_hw_mask2] Nothing
 623               ]
 624 #        else
 625             = CSequential [ a_hw_shift,
 626                  CMachOpStmt (Just res) MO_Nat_Shr [arg, t_hw_shift] Nothing
 627               ]
 628 #        endif
 629      in
 630          returnFlt final
 631
 632
 633 mkTemp :: PrimRep -> FlatM CAddrMode
 634 mkTemp rep
 635    = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
 636
 637 mkTemps = mapFlt mkTemp
 638
 639 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 640 mkDerefOff rep base off
 641    | off == 0   -- optimisation
 642    = CMem rep base
 643    | otherwise
 644    = CMem rep (CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep))
 645
 646 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 647 mkNoDerefOff rep base off
 648    = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
 649
 650 -- Sigh.  This is done in 3 seperate places.  Should be
 651 -- commoned up (here, in pprAbsC of COpStmt, and presumably
 652 -- somewhere in the NCG).
 653 non_void_amode amode
 654    = case getAmodeRep amode of
 655         VoidRep -> False
 656         k       -> True
 657
 658 doIndexOffForeignObjOp rep res addr idx
 659    = Just (Just res, MO_ReadOSBI fixedHdrSize rep, [addr,idx])
 660
 661 doIndexOffAddrOp rep res addr idx
 662    = Just (Just res, MO_ReadOSBI 0 rep, [addr,idx])
 663
 664 doIndexByteArrayOp rep res addr idx
 665    = Just (Just res, MO_ReadOSBI arrWordsHdrSize rep, [addr,idx])
 666
 667 doWriteOffAddrOp rep addr idx val
 668    = Just (Nothing, MO_WriteOSBI 0 rep, [addr,idx,val])
 669
 670 doWriteByteArrayOp rep addr idx val
 671    = Just (Nothing, MO_WriteOSBI arrWordsHdrSize rep, [addr,idx,val])
 672
 673 -- Simple dyadic op but one for which we need to cast first arg to
 674 -- be sure of correctness
 675 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
 676    = mkTemp cast_arg1_to                `thenFlt` \ arg1casted ->
 677      (returnFlt . CSequential) [
 678         CAssign arg1casted arg1,
 679         CMachOpStmt (Just res) mop [arg1casted,arg2]
 680            (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 681      ]
 682
 683 getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
 684 getBitsPerWordMinus1
 685    = mkTemps [IntRep, IntRep]           `thenFlt` \ [t1,t2] ->
 686      returnFlt (
 687         CSequential [
 688            CMachOpStmt (Just t1) MO_Nat_Shl
 689                        [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
 690            CMachOpStmt (Just t2) MO_Nat_Sub
 691                        [t1, CLit (mkMachInt 1)] Nothing
 692         ],
 693         t2
 694      )
 695
 696 ------------------------------------------------------------------------------
 697
 698 dscCOpStmt :: [CAddrMode]       -- Results
 699            -> PrimOp
 700            -> [CAddrMode]       -- Arguments
 701            -> [MagicId]         -- Potentially volatile/live registers
 702                                 -- (to save/restore around the op)
 703            -> FlatM AbstractC
 704
 705
 706 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
 707 {-
 708    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 709    C, and without needing any comparisons.  This may not be the
 710    fastest way to do it - if you have better code, please send it! --SDM
 711
 712    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 713
 714    We currently don't make use of the r value if c is != 0 (i.e.
 715    overflow), we just convert to big integers and try again.  This
 716    could be improved by making r and c the correct values for
 717    plugging into a new J#.
 718
 719    { r = ((I_)(a)) + ((I_)(b));                                 \
 720      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
 721          >> (BITS_IN (I_) - 1);                                 \
 722    }
 723    Wading through the mass of bracketry, it seems to reduce to:
 724    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
 725
 726    SSA-form:
 727    t1 = a^b
 728    t2 = ~t1
 729    t3 = a^r
 730    t4 = t2 & t3
 731    c  = t4 >>unsigned BITS_IN(I_)-1
 732 -}
 733    = mkTemps [IntRep,IntRep,IntRep,IntRep]      `thenFlt` \ [t1,t2,t3,t4] ->
 734      getBitsPerWordMinus1                       `thenFlt` \ (bpw1_code,bpw1_t) ->
 735      (returnFlt . CSequential) [
 736         CMachOpStmt (Just res_r) MO_Nat_Add [aa,bb] Nothing,
 737         CMachOpStmt (Just t1) MO_Nat_Xor [aa,bb] Nothing,
 738         CMachOpStmt (Just t2) MO_Nat_Not [t1] Nothing,
 739         CMachOpStmt (Just t3) MO_Nat_Xor [aa,res_r] Nothing,
 740         CMachOpStmt (Just t4) MO_Nat_And [t2,t3] Nothing,
 741         bpw1_code,
 742         CMachOpStmt (Just res_c) MO_Nat_Shr [t4, bpw1_t] Nothing
 743      ]
 744
 745
 746 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
 747 {- Similarly:
 748    #define subIntCzh(r,c,a,b)                                   \
 749    { r = ((I_)(a)) - ((I_)(b));                                 \
 750      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
 751          >> (BITS_IN (I_) - 1);                                 \
 752    }
 753
 754    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
 755
 756    t1 = a^b
 757    t2 = a^r
 758    t3 = t1 & t2
 759    c  = t3 >>unsigned BITS_IN(I_)-1
 760 -}
 761    = mkTemps [IntRep,IntRep,IntRep]             `thenFlt` \ [t1,t2,t3] ->
 762      getBitsPerWordMinus1                       `thenFlt` \ (bpw1_code,bpw1_t) ->
 763      (returnFlt . CSequential) [
 764         CMachOpStmt (Just res_r) MO_Nat_Add [aa,bb] Nothing,
 765         CMachOpStmt (Just t1) MO_Nat_Xor [aa,bb] Nothing,
 766         CMachOpStmt (Just t2) MO_Nat_Xor [aa,res_r] Nothing,
 767         CMachOpStmt (Just t3) MO_Nat_And [t2,t3] Nothing,
 768         bpw1_code,
 769         CMachOpStmt (Just res_c) MO_Nat_Shr [t3, bpw1_t] Nothing
 770      ]
 771
 772
 773 -- #define parzh(r,node) r = 1
 774 dscCOpStmt [res] ParOp [arg] vols
 775    = returnFlt
 776         (CAssign res (CLit (mkMachInt 1)))
 777
 778 -- #define readMutVarzh(r,a)     r=(P_)(((StgMutVar *)(a))->var)
 779 dscCOpStmt [res] ReadMutVarOp [mutv] vols
 780    = returnFlt
 781         (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
 782
 783 -- #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 784 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
 785    = returnFlt
 786         (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
 787
 788
 789 -- #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 790 -- #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 791 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
 792    = returnFlt
 793         (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
 794
 795 -- #define writeForeignObjzh(res,datum) \
 796 --    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 797 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
 798    = returnFlt
 799         (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
 800
 801
 802 -- #define sizzeofByteArrayzh(r,a) \
 803 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 804 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 805    = mkTemp WordRep                     `thenFlt` \ w ->
 806      (returnFlt . CSequential) [
 807         CAssign w (mkDerefOff WordRep arg fixedHdrSize),
 808         CMachOpStmt (Just w)
 809            MO_NatU_Mul [w, CBytesPerWord] (Just vols),
 810         CAssign res w
 811      ]
 812
 813 -- #define sizzeofMutableByteArrayzh(r,a) \
 814 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
 815 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
 816    = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 817
 818
 819 -- #define touchzh(o)                  /* nothing */
 820 dscCOpStmt [] TouchOp [arg] vols
 821    = returnFlt AbsCNop
 822
 823 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 824 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
 825    = mkTemp PtrRep                      `thenFlt` \ ptr ->
 826      (returnFlt . CSequential) [
 827          CMachOpStmt (Just ptr) MO_NatU_to_NatP [arg] Nothing,
 828          CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
 829          CAssign res ptr
 830      ]
 831
 832 -- #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 833 dscCOpStmt [res] StableNameToIntOp [arg] vols
 834    = returnFlt
 835         (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
 836
 837 -- #define eqStableNamezh(r,sn1,sn2)                                    \
 838 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 839 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
 840    = mkTemps [WordRep, WordRep]         `thenFlt` \ [sn1,sn2] ->
 841      (returnFlt . CSequential) [
 842         CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
 843         CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
 844         CMachOpStmt (Just res) MO_Nat_Eq [sn1,sn2] Nothing
 845      ]
 846
 847 -- #define addrToHValuezh(r,a) r=(P_)a
 848 dscCOpStmt [res] AddrToHValueOp [arg] vols
 849    = returnFlt
 850         (CAssign res arg)
 851
 852 -- #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 853 dscCOpStmt [res] DataToTagOp [arg] vols
 854    = mkTemps [PtrRep, WordRep]          `thenFlt` \ [t_infoptr, t_theword] ->
 855      mkHalfWord_HIADDR res t_theword    `thenFlt` \ select_ops ->
 856      (returnFlt . CSequential) [
 857         CAssign t_infoptr (mkDerefOff PtrRep arg 0),
 858         CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
 859         select_ops
 860      ]
 861
 862
 863 {- Freezing arrays-of-ptrs requires changing an info table, for the
 864    benefit of the generational collector.  It needs to scavenge mutable
 865    objects, even if they are in old space.  When they become immutable,
 866    they can be removed from this scavenge list.  -}
 867
 868 -- #define unsafeFreezzeArrayzh(r,a)                                    \
 869 --      {                                                               \
 870 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 871 --      r = a;                                                          \
 872 --      }
 873 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
 874    = (returnFlt . CSequential) [
 875         CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
 876         CAssign res arg
 877      ]
 878
 879 -- #define unsafeFreezzeByteArrayzh(r,a)        r=(a)
 880 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
 881    = returnFlt
 882         (CAssign res arg)
 883
 884 -- This ought to be trivial, but it's difficult to insert the casts
 885 -- required to keep the C compiler happy.
 886 dscCOpStmt [r] AddrRemOp [a1,a2] vols
 887    = mkTemp WordRep                     `thenFlt` \ a1casted ->
 888      (returnFlt . CSequential) [
 889         CMachOpStmt (Just a1casted) MO_NatP_to_NatU [a1] Nothing,
 890         CMachOpStmt (Just r) MO_NatU_Rem [a1casted,a2] Nothing
 891      ]
 892
 893 -- not handled by translateOp because they need casts
 894 dscCOpStmt [r] SllOp [a1,a2] vols
 895    = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
 896 dscCOpStmt [r] SrlOp [a1,a2] vols
 897    = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
 898
 899 dscCOpStmt [r] ISllOp [a1,a2] vols
 900    = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
 901 dscCOpStmt [r] ISrlOp [a1,a2] vols
 902    = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
 903 dscCOpStmt [r] ISraOp [a1,a2] vols
 904    = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
 905
 906
 907 -- Handle all others as simply as possible.
 908 dscCOpStmt ress op args vols
 909    = case translateOp ress op args of
 910         Nothing
 911            -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
 912         Just (maybe_res, mop, args)
 913            -> returnFlt (
 914                  CMachOpStmt maybe_res mop args
 915                     (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 916               )
 917
 918
 919
 920 translateOp [r] ReadArrayOp [obj,ix]
 921    = Just (Just r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
 922 translateOp [r] IndexArrayOp [obj,ix]
 923    = Just (Just r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
 924 translateOp [] WriteArrayOp [obj,ix,v]
 925    = Just (Nothing, MO_WriteOSBI arrPtrsHdrSize PtrRep, [obj,ix,v])
 926
 927 -- IndexXXXoffForeignObj
 928
 929 translateOp [r] IndexOffForeignObjOp_Char [a,i]  = doIndexOffForeignObjOp Word8Rep r a i
 930 translateOp [r] IndexOffForeignObjOp_WideChar [a,i]  = doIndexOffForeignObjOp Word32Rep r a i
 931 translateOp [r] IndexOffForeignObjOp_Int [a,i]  = doIndexOffForeignObjOp IntRep r a i
 932 translateOp [r] IndexOffForeignObjOp_Word [a,i]  = doIndexOffForeignObjOp WordRep r a i
 933 translateOp [r] IndexOffForeignObjOp_Addr [a,i]  = doIndexOffForeignObjOp AddrRep r a i
 934 translateOp [r] IndexOffForeignObjOp_Float [a,i]  = doIndexOffForeignObjOp FloatRep r a i
 935 translateOp [r] IndexOffForeignObjOp_Double [a,i]  = doIndexOffForeignObjOp DoubleRep r a i
 936 translateOp [r] IndexOffForeignObjOp_StablePtr [a,i]  = doIndexOffForeignObjOp StablePtrRep r a i
 937
 938 translateOp [r] IndexOffForeignObjOp_Int8  [a,i] = doIndexOffForeignObjOp Int8Rep  r a i
 939 translateOp [r] IndexOffForeignObjOp_Int16 [a,i] = doIndexOffForeignObjOp Int16Rep r a i
 940 translateOp [r] IndexOffForeignObjOp_Int32 [a,i] = doIndexOffForeignObjOp Int32Rep r a i
 941 translateOp [r] IndexOffForeignObjOp_Int64 [a,i] = doIndexOffForeignObjOp Int64Rep r a i
 942
 943 translateOp [r] IndexOffForeignObjOp_Word8  [a,i] = doIndexOffForeignObjOp Word8Rep  r a i
 944 translateOp [r] IndexOffForeignObjOp_Word16 [a,i] = doIndexOffForeignObjOp Word16Rep r a i
 945 translateOp [r] IndexOffForeignObjOp_Word32 [a,i] = doIndexOffForeignObjOp Word32Rep r a i
 946 translateOp [r] IndexOffForeignObjOp_Word64 [a,i] = doIndexOffForeignObjOp Word64Rep r a i
 947
 948 -- IndexXXXoffAddr
 949
 950 translateOp [r] IndexOffAddrOp_Char [a,i]  = doIndexOffAddrOp Word8Rep r a i
 951 translateOp [r] IndexOffAddrOp_WideChar [a,i]  = doIndexOffAddrOp Word32Rep r a i
 952 translateOp [r] IndexOffAddrOp_Int [a,i]  = doIndexOffAddrOp IntRep r a i
 953 translateOp [r] IndexOffAddrOp_Word [a,i]  = doIndexOffAddrOp WordRep r a i
 954 translateOp [r] IndexOffAddrOp_Addr [a,i]  = doIndexOffAddrOp AddrRep r a i
 955 translateOp [r] IndexOffAddrOp_Float [a,i]  = doIndexOffAddrOp FloatRep r a i
 956 translateOp [r] IndexOffAddrOp_Double [a,i]  = doIndexOffAddrOp DoubleRep r a i
 957 translateOp [r] IndexOffAddrOp_StablePtr [a,i]  = doIndexOffAddrOp StablePtrRep r a i
 958
 959 translateOp [r] IndexOffAddrOp_Int8  [a,i] = doIndexOffAddrOp Int8Rep  r a i
 960 translateOp [r] IndexOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
 961 translateOp [r] IndexOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
 962 translateOp [r] IndexOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
 963
 964 translateOp [r] IndexOffAddrOp_Word8  [a,i] = doIndexOffAddrOp Word8Rep  r a i
 965 translateOp [r] IndexOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
 966 translateOp [r] IndexOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
 967 translateOp [r] IndexOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
 968
 969 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 970
 971 translateOp [r] ReadOffAddrOp_Char [a,i]  = doIndexOffAddrOp Word8Rep r a i
 972 translateOp [r] ReadOffAddrOp_WideChar [a,i]  = doIndexOffAddrOp Word32Rep r a i
 973 translateOp [r] ReadOffAddrOp_Int [a,i]  = doIndexOffAddrOp IntRep r a i
 974 translateOp [r] ReadOffAddrOp_Word [a,i]  = doIndexOffAddrOp WordRep r a i
 975 translateOp [r] ReadOffAddrOp_Addr [a,i]  = doIndexOffAddrOp AddrRep r a i
 976 translateOp [r] ReadOffAddrOp_Float [a,i]  = doIndexOffAddrOp FloatRep r a i
 977 translateOp [r] ReadOffAddrOp_Double [a,i]  = doIndexOffAddrOp DoubleRep r a i
 978 translateOp [r] ReadOffAddrOp_StablePtr [a,i]  = doIndexOffAddrOp StablePtrRep r a i
 979
 980 translateOp [r] ReadOffAddrOp_Int8  [a,i] = doIndexOffAddrOp Int8Rep  r a i
 981 translateOp [r] ReadOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
 982 translateOp [r] ReadOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
 983 translateOp [r] ReadOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
 984
 985 translateOp [r] ReadOffAddrOp_Word8  [a,i] = doIndexOffAddrOp Word8Rep  r a i
 986 translateOp [r] ReadOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
 987 translateOp [r] ReadOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
 988 translateOp [r] ReadOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
 989
 990 -- WriteXXXoffAddr
 991
 992 translateOp [] WriteOffAddrOp_Char [a,i,x]  = doWriteOffAddrOp Word8Rep a i x
 993 translateOp [] WriteOffAddrOp_WideChar [a,i,x]  = doWriteOffAddrOp Word32Rep a i x
 994 translateOp [] WriteOffAddrOp_Int [a,i,x]  = doWriteOffAddrOp IntRep a i x
 995 translateOp [] WriteOffAddrOp_Word [a,i,x]  = doWriteOffAddrOp WordRep a i x
 996 translateOp [] WriteOffAddrOp_Addr [a,i,x]  = doWriteOffAddrOp AddrRep a i x
 997 translateOp [] WriteOffAddrOp_Float [a,i,x]  = doWriteOffAddrOp FloatRep a i x
 998 translateOp [] WriteOffAddrOp_ForeignObj [a,i,x]  = doWriteOffAddrOp ForeignObjRep a i x
 999 translateOp [] WriteOffAddrOp_Double [a,i,x]  = doWriteOffAddrOp DoubleRep a i x
1000 translateOp [] WriteOffAddrOp_StablePtr [a,i,x]  = doWriteOffAddrOp StablePtrRep a i x
1001
1002 translateOp [] WriteOffAddrOp_Int8  [a,i,x] = doWriteOffAddrOp Int8Rep  a i x
1003 translateOp [] WriteOffAddrOp_Int16 [a,i,x] = doWriteOffAddrOp Int16Rep a i x
1004 translateOp [] WriteOffAddrOp_Int32 [a,i,x] = doWriteOffAddrOp Int32Rep a i x
1005 translateOp [] WriteOffAddrOp_Int64 [a,i,x] = doWriteOffAddrOp Int64Rep a i x
1006
1007 translateOp [] WriteOffAddrOp_Word8  [a,i,x] = doWriteOffAddrOp Word8Rep  a i x
1008 translateOp [] WriteOffAddrOp_Word16 [a,i,x] = doWriteOffAddrOp Word16Rep a i x
1009 translateOp [] WriteOffAddrOp_Word32 [a,i,x] = doWriteOffAddrOp Word32Rep a i x
1010 translateOp [] WriteOffAddrOp_Word64 [a,i,x] = doWriteOffAddrOp Word64Rep a i x
1011
1012 -- IndexXXXArray
1013
1014 translateOp [r] IndexByteArrayOp_Char [a,i]  = doIndexByteArrayOp Word8Rep r a i
1015 translateOp [r] IndexByteArrayOp_WideChar [a,i]  = doIndexByteArrayOp Word32Rep r a i
1016 translateOp [r] IndexByteArrayOp_Int [a,i]  = doIndexByteArrayOp IntRep r a i
1017 translateOp [r] IndexByteArrayOp_Word [a,i]  = doIndexByteArrayOp WordRep r a i
1018 translateOp [r] IndexByteArrayOp_Addr [a,i]  = doIndexByteArrayOp AddrRep r a i
1019 translateOp [r] IndexByteArrayOp_Float [a,i]  = doIndexByteArrayOp FloatRep r a i
1020 translateOp [r] IndexByteArrayOp_Double [a,i]  = doIndexByteArrayOp DoubleRep r a i
1021 translateOp [r] IndexByteArrayOp_StablePtr [a,i]  = doIndexByteArrayOp StablePtrRep r a i
1022
1023 translateOp [r] IndexByteArrayOp_Int8  [a,i] = doIndexByteArrayOp Int8Rep  r a i
1024 translateOp [r] IndexByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep  r a i
1025 translateOp [r] IndexByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep  r a i
1026 translateOp [r] IndexByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep  r a i
1027
1028 translateOp [r] IndexByteArrayOp_Word8  [a,i] = doIndexByteArrayOp Word8Rep  r a i
1029 translateOp [r] IndexByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep  r a i
1030 translateOp [r] IndexByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep  r a i
1031 translateOp [r] IndexByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep  r a i
1032
1033 -- ReadXXXArray, identical to IndexXXXArray.
1034
1035 translateOp [r] ReadByteArrayOp_Char [a,i]  = doIndexByteArrayOp Word8Rep r a i
1036 translateOp [r] ReadByteArrayOp_WideChar [a,i]  = doIndexByteArrayOp Word32Rep r a i
1037 translateOp [r] ReadByteArrayOp_Int [a,i]  = doIndexByteArrayOp IntRep r a i
1038 translateOp [r] ReadByteArrayOp_Word [a,i]  = doIndexByteArrayOp WordRep r a i
1039 translateOp [r] ReadByteArrayOp_Addr [a,i]  = doIndexByteArrayOp AddrRep r a i
1040 translateOp [r] ReadByteArrayOp_Float [a,i]  = doIndexByteArrayOp FloatRep r a i
1041 translateOp [r] ReadByteArrayOp_Double [a,i]  = doIndexByteArrayOp DoubleRep r a i
1042 translateOp [r] ReadByteArrayOp_StablePtr [a,i]  = doIndexByteArrayOp StablePtrRep r a i
1043
1044 translateOp [r] ReadByteArrayOp_Int8  [a,i] = doIndexByteArrayOp Int8Rep  r a i
1045 translateOp [r] ReadByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep  r a i
1046 translateOp [r] ReadByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep  r a i
1047 translateOp [r] ReadByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep  r a i
1048
1049 translateOp [r] ReadByteArrayOp_Word8  [a,i] = doIndexByteArrayOp Word8Rep  r a i
1050 translateOp [r] ReadByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep  r a i
1051 translateOp [r] ReadByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep  r a i
1052 translateOp [r] ReadByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep  r a i
1053
1054 -- WriteXXXArray
1055
1056 translateOp [] WriteByteArrayOp_Char [a,i,x]  = doWriteByteArrayOp Word8Rep a i x
1057 translateOp [] WriteByteArrayOp_WideChar [a,i,x]  = doWriteByteArrayOp Word32Rep a i x
1058 translateOp [] WriteByteArrayOp_Int [a,i,x]  = doWriteByteArrayOp IntRep a i x
1059 translateOp [] WriteByteArrayOp_Word [a,i,x]  = doWriteByteArrayOp WordRep a i x
1060 translateOp [] WriteByteArrayOp_Addr [a,i,x]  = doWriteByteArrayOp AddrRep a i x
1061 translateOp [] WriteByteArrayOp_Float [a,i,x]  = doWriteByteArrayOp FloatRep a i x
1062 translateOp [] WriteByteArrayOp_Double [a,i,x]  = doWriteByteArrayOp DoubleRep a i x
1063 translateOp [] WriteByteArrayOp_StablePtr [a,i,x]  = doWriteByteArrayOp StablePtrRep a i x
1064
1065 translateOp [] WriteByteArrayOp_Int8  [a,i,x] = doWriteByteArrayOp Int8Rep  a i x
1066 translateOp [] WriteByteArrayOp_Int16 [a,i,x] = doWriteByteArrayOp Int16Rep  a i x
1067 translateOp [] WriteByteArrayOp_Int32 [a,i,x] = doWriteByteArrayOp Int32Rep  a i x
1068 translateOp [] WriteByteArrayOp_Int64 [a,i,x] = doWriteByteArrayOp Int64Rep  a i x
1069
1070 translateOp [] WriteByteArrayOp_Word8  [a,i,x] = doWriteByteArrayOp Word8Rep  a i x
1071 translateOp [] WriteByteArrayOp_Word16 [a,i,x] = doWriteByteArrayOp Word16Rep  a i x
1072 translateOp [] WriteByteArrayOp_Word32 [a,i,x] = doWriteByteArrayOp Word32Rep  a i x
1073 translateOp [] WriteByteArrayOp_Word64 [a,i,x] = doWriteByteArrayOp Word64Rep  a i x
1074
1075 -- Native word signless ops
1076
1077 translateOp [r] IntAddOp       [a1,a2] = Just (Just r, MO_Nat_Add,        [a1,a2])
1078 translateOp [r] IntSubOp       [a1,a2] = Just (Just r, MO_Nat_Sub,        [a1,a2])
1079 translateOp [r] WordAddOp      [a1,a2] = Just (Just r, MO_Nat_Add,        [a1,a2])
1080 translateOp [r] WordSubOp      [a1,a2] = Just (Just r, MO_Nat_Sub,        [a1,a2])
1081 translateOp [r] AddrAddOp      [a1,a2] = Just (Just r, MO_Nat_Add,        [a1,a2])
1082 translateOp [r] AddrSubOp      [a1,a2] = Just (Just r, MO_Nat_Sub,        [a1,a2])
1083
1084 translateOp [r] IntEqOp        [a1,a2] = Just (Just r, MO_Nat_Eq,         [a1,a2])
1085 translateOp [r] IntNeOp        [a1,a2] = Just (Just r, MO_Nat_Ne,         [a1,a2])
1086 translateOp [r] WordEqOp       [a1,a2] = Just (Just r, MO_Nat_Eq,         [a1,a2])
1087 translateOp [r] WordNeOp       [a1,a2] = Just (Just r, MO_Nat_Ne,         [a1,a2])
1088 translateOp [r] AddrEqOp       [a1,a2] = Just (Just r, MO_Nat_Eq,         [a1,a2])
1089 translateOp [r] AddrNeOp       [a1,a2] = Just (Just r, MO_Nat_Ne,         [a1,a2])
1090
1091 translateOp [r] AndOp          [a1,a2] = Just (Just r, MO_Nat_And,        [a1,a2])
1092 translateOp [r] OrOp           [a1,a2] = Just (Just r, MO_Nat_Or,         [a1,a2])
1093 translateOp [r] XorOp          [a1,a2] = Just (Just r, MO_Nat_Xor,        [a1,a2])
1094 translateOp [r] NotOp          [a1]    = Just (Just r, MO_Nat_Not,        [a1])
1095
1096 -- Native word signed ops
1097
1098 translateOp [r] IntMulOp       [a1,a2] = Just (Just r, MO_NatS_Mul,       [a1,a2])
1099 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (Just r, MO_NatS_MulMayOflo, [a1,a2])
1100 translateOp [r] IntQuotOp      [a1,a2] = Just (Just r, MO_NatS_Quot,      [a1,a2])
1101 translateOp [r] IntRemOp       [a1,a2] = Just (Just r, MO_NatS_Rem,       [a1,a2])
1102 translateOp [r] IntNegOp       [a1]    = Just (Just r, MO_NatS_Neg,       [a1])
1103
1104 translateOp [r] IntGeOp        [a1,a2] = Just (Just r, MO_NatS_Ge,        [a1,a2])
1105 translateOp [r] IntLeOp        [a1,a2] = Just (Just r, MO_NatS_Le,        [a1,a2])
1106 translateOp [r] IntGtOp        [a1,a2] = Just (Just r, MO_NatS_Gt,        [a1,a2])
1107 translateOp [r] IntLtOp        [a1,a2] = Just (Just r, MO_NatS_Lt,        [a1,a2])
1108
1109
1110 -- Native word unsigned ops
1111
1112 translateOp [r] WordGeOp       [a1,a2] = Just (Just r, MO_NatU_Ge,        [a1,a2])
1113 translateOp [r] WordLeOp       [a1,a2] = Just (Just r, MO_NatU_Le,        [a1,a2])
1114 translateOp [r] WordGtOp       [a1,a2] = Just (Just r, MO_NatU_Gt,        [a1,a2])
1115 translateOp [r] WordLtOp       [a1,a2] = Just (Just r, MO_NatU_Lt,        [a1,a2])
1116
1117 translateOp [r] WordMulOp      [a1,a2] = Just (Just r, MO_NatU_Mul,       [a1,a2])
1118 translateOp [r] WordQuotOp     [a1,a2] = Just (Just r, MO_NatU_Quot,      [a1,a2])
1119 translateOp [r] WordRemOp      [a1,a2] = Just (Just r, MO_NatU_Rem,       [a1,a2])
1120
1121 translateOp [r] AddrGeOp       [a1,a2] = Just (Just r, MO_NatU_Ge,        [a1,a2])
1122 translateOp [r] AddrLeOp       [a1,a2] = Just (Just r, MO_NatU_Le,        [a1,a2])
1123 translateOp [r] AddrGtOp       [a1,a2] = Just (Just r, MO_NatU_Gt,        [a1,a2])
1124 translateOp [r] AddrLtOp       [a1,a2] = Just (Just r, MO_NatU_Lt,        [a1,a2])
1125
1126 -- 32-bit unsigned ops
1127
1128 translateOp [r] CharEqOp       [a1,a2] = Just (Just r, MO_32U_Eq,        [a1,a2])
1129 translateOp [r] CharNeOp       [a1,a2] = Just (Just r, MO_32U_Ne,        [a1,a2])
1130 translateOp [r] CharGeOp       [a1,a2] = Just (Just r, MO_32U_Ge,        [a1,a2])
1131 translateOp [r] CharLeOp       [a1,a2] = Just (Just r, MO_32U_Le,        [a1,a2])
1132 translateOp [r] CharGtOp       [a1,a2] = Just (Just r, MO_32U_Gt,        [a1,a2])
1133 translateOp [r] CharLtOp       [a1,a2] = Just (Just r, MO_32U_Lt,        [a1,a2])
1134
1135 -- Double ops
1136
1137 translateOp [r] DoubleEqOp     [a1,a2] = Just (Just r, MO_Dbl_Eq,      [a1,a2])
1138 translateOp [r] DoubleNeOp     [a1,a2] = Just (Just r, MO_Dbl_Ne,      [a1,a2])
1139 translateOp [r] DoubleGeOp     [a1,a2] = Just (Just r, MO_Dbl_Ge,      [a1,a2])
1140 translateOp [r] DoubleLeOp     [a1,a2] = Just (Just r, MO_Dbl_Le,      [a1,a2])
1141 translateOp [r] DoubleGtOp     [a1,a2] = Just (Just r, MO_Dbl_Gt,      [a1,a2])
1142 translateOp [r] DoubleLtOp     [a1,a2] = Just (Just r, MO_Dbl_Lt,      [a1,a2])
1143
1144 translateOp [r] DoubleAddOp    [a1,a2] = Just (Just r, MO_Dbl_Add,    [a1,a2])
1145 translateOp [r] DoubleSubOp    [a1,a2] = Just (Just r, MO_Dbl_Sub,    [a1,a2])
1146 translateOp [r] DoubleMulOp    [a1,a2] = Just (Just r, MO_Dbl_Mul,    [a1,a2])
1147 translateOp [r] DoubleDivOp    [a1,a2] = Just (Just r, MO_Dbl_Div,    [a1,a2])
1148 translateOp [r] DoublePowerOp  [a1,a2] = Just (Just r, MO_Dbl_Pwr,    [a1,a2])
1149
1150 translateOp [r] DoubleSinOp    [a1]    = Just (Just r, MO_Dbl_Sin,    [a1])
1151 translateOp [r] DoubleCosOp    [a1]    = Just (Just r, MO_Dbl_Cos,    [a1])
1152 translateOp [r] DoubleTanOp    [a1]    = Just (Just r, MO_Dbl_Tan,    [a1])
1153 translateOp [r] DoubleSinhOp   [a1]    = Just (Just r, MO_Dbl_Sinh,   [a1])
1154 translateOp [r] DoubleCoshOp   [a1]    = Just (Just r, MO_Dbl_Cosh,   [a1])
1155 translateOp [r] DoubleTanhOp   [a1]    = Just (Just r, MO_Dbl_Tanh,   [a1])
1156 translateOp [r] DoubleAsinOp   [a1]    = Just (Just r, MO_Dbl_Asin,    [a1])
1157 translateOp [r] DoubleAcosOp   [a1]    = Just (Just r, MO_Dbl_Acos,    [a1])
1158 translateOp [r] DoubleAtanOp   [a1]    = Just (Just r, MO_Dbl_Atan,    [a1])
1159 translateOp [r] DoubleLogOp    [a1]    = Just (Just r, MO_Dbl_Log,    [a1])
1160 translateOp [r] DoubleExpOp    [a1]    = Just (Just r, MO_Dbl_Exp,    [a1])
1161 translateOp [r] DoubleSqrtOp   [a1]    = Just (Just r, MO_Dbl_Sqrt,    [a1])
1162 translateOp [r] DoubleNegOp    [a1]    = Just (Just r, MO_Dbl_Neg,    [a1])
1163
1164 -- Float ops
1165
1166 translateOp [r] FloatEqOp     [a1,a2] = Just (Just r, MO_Flt_Eq,      [a1,a2])
1167 translateOp [r] FloatNeOp     [a1,a2] = Just (Just r, MO_Flt_Ne,      [a1,a2])
1168 translateOp [r] FloatGeOp     [a1,a2] = Just (Just r, MO_Flt_Ge,      [a1,a2])
1169 translateOp [r] FloatLeOp     [a1,a2] = Just (Just r, MO_Flt_Le,      [a1,a2])
1170 translateOp [r] FloatGtOp     [a1,a2] = Just (Just r, MO_Flt_Gt,      [a1,a2])
1171 translateOp [r] FloatLtOp     [a1,a2] = Just (Just r, MO_Flt_Lt,      [a1,a2])
1172
1173 translateOp [r] FloatAddOp    [a1,a2] = Just (Just r, MO_Flt_Add,    [a1,a2])
1174 translateOp [r] FloatSubOp    [a1,a2] = Just (Just r, MO_Flt_Sub,    [a1,a2])
1175 translateOp [r] FloatMulOp    [a1,a2] = Just (Just r, MO_Flt_Mul,    [a1,a2])
1176 translateOp [r] FloatDivOp    [a1,a2] = Just (Just r, MO_Flt_Div,    [a1,a2])
1177 translateOp [r] FloatPowerOp  [a1,a2] = Just (Just r, MO_Flt_Pwr,    [a1,a2])
1178
1179 translateOp [r] FloatSinOp    [a1]    = Just (Just r, MO_Flt_Sin,    [a1])
1180 translateOp [r] FloatCosOp    [a1]    = Just (Just r, MO_Flt_Cos,    [a1])
1181 translateOp [r] FloatTanOp    [a1]    = Just (Just r, MO_Flt_Tan,    [a1])
1182 translateOp [r] FloatSinhOp   [a1]    = Just (Just r, MO_Flt_Sinh,   [a1])
1183 translateOp [r] FloatCoshOp   [a1]    = Just (Just r, MO_Flt_Cosh,   [a1])
1184 translateOp [r] FloatTanhOp   [a1]    = Just (Just r, MO_Flt_Tanh,   [a1])
1185 translateOp [r] FloatAsinOp   [a1]    = Just (Just r, MO_Flt_Asin,    [a1])
1186 translateOp [r] FloatAcosOp   [a1]    = Just (Just r, MO_Flt_Acos,    [a1])
1187 translateOp [r] FloatAtanOp   [a1]    = Just (Just r, MO_Flt_Atan,    [a1])
1188 translateOp [r] FloatLogOp    [a1]    = Just (Just r, MO_Flt_Log,    [a1])
1189 translateOp [r] FloatExpOp    [a1]    = Just (Just r, MO_Flt_Exp,    [a1])
1190 translateOp [r] FloatSqrtOp   [a1]    = Just (Just r, MO_Flt_Sqrt,    [a1])
1191 translateOp [r] FloatNegOp    [a1]    = Just (Just r, MO_Flt_Neg,    [a1])
1192
1193 -- Conversions
1194
1195 translateOp [r] Int2DoubleOp   [a1]   = Just (Just r, MO_NatS_to_Dbl,   [a1])
1196 translateOp [r] Double2IntOp   [a1]   = Just (Just r, MO_Dbl_to_NatS,   [a1])
1197
1198 translateOp [r] Int2FloatOp    [a1]   = Just (Just r, MO_NatS_to_Flt,   [a1])
1199 translateOp [r] Float2IntOp    [a1]   = Just (Just r, MO_Flt_to_NatS,   [a1])
1200
1201 translateOp [r] Float2DoubleOp [a1]   = Just (Just r, MO_Flt_to_Dbl,    [a1])
1202 translateOp [r] Double2FloatOp [a1]   = Just (Just r, MO_Dbl_to_Flt,    [a1])
1203
1204 translateOp [r] Int2WordOp     [a1]   = Just (Just r, MO_NatS_to_NatU,  [a1])
1205 translateOp [r] Word2IntOp     [a1]   = Just (Just r, MO_NatU_to_NatS,  [a1])
1206
1207 translateOp [r] Int2AddrOp     [a1]   = Just (Just r, MO_NatS_to_NatP,  [a1])
1208 translateOp [r] Addr2IntOp     [a1]   = Just (Just r, MO_NatP_to_NatS,  [a1])
1209
1210 translateOp [r] OrdOp          [a1]   = Just (Just r, MO_32U_to_NatS,   [a1])
1211 translateOp [r] ChrOp          [a1]   = Just (Just r, MO_NatS_to_32U,   [a1])
1212
1213 translateOp [r] Narrow8IntOp   [a1]   = Just (Just r, MO_8S_to_NatS,    [a1])
1214 translateOp [r] Narrow16IntOp  [a1]   = Just (Just r, MO_16S_to_NatS,   [a1])
1215 translateOp [r] Narrow32IntOp  [a1]   = Just (Just r, MO_32S_to_NatS,   [a1])
1216
1217 translateOp [r] Narrow8WordOp   [a1]  = Just (Just r, MO_8U_to_NatU,    [a1])
1218 translateOp [r] Narrow16WordOp  [a1]  = Just (Just r, MO_16U_to_NatU,   [a1])
1219 translateOp [r] Narrow32WordOp  [a1]  = Just (Just r, MO_32U_to_NatU,   [a1])
1220
1221 -- Word comparisons masquerading as more exotic things.
1222
1223 translateOp [r] SameMutVarOp   [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1224 translateOp [r] SameMVarOp     [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1225 translateOp [r] SameMutableArrayOp  [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1226 translateOp [r] SameMutableByteArrayOp [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1227 translateOp [r] EqForeignObj [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1228 translateOp [r] EqStablePtrOp [a1,a2]  = Just (Just r, MO_Nat_Eq,    [a1,a2])
1229
1230 translateOp _ _ _ = Nothing
1231
1232 \end{code}