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 Maybes           ( Maybe012(..) )
  38 import Outputable
  39 import Panic            ( panic )
  40 import FastTypes
  41
  42 import Maybe            ( isJust, maybeToList )
  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 Su                   = PtrRep
 148 magicIdPrimRep SpLim                = PtrRep
 149 magicIdPrimRep Hp                   = PtrRep
 150 magicIdPrimRep HpLim                = PtrRep
 151 magicIdPrimRep CurCostCentre        = CostCentreRep
 152 magicIdPrimRep VoidReg              = VoidRep
 153 magicIdPrimRep CurrentTSO           = ThreadIdRep
 154 magicIdPrimRep CurrentNursery       = PtrRep
 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 getAmodeRep (CMem rep addr)                 = rep
 181 \end{code}
 182
 183 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
 184 location; that is, one which can contain values of various types.
 185
 186 \begin{code}
 187 mixedTypeLocn :: CAddrMode -> Bool
 188
 189 mixedTypeLocn (CVal (NodeRel _) _)      = True
 190 mixedTypeLocn (CVal (SpRel _)   _)      = True
 191 mixedTypeLocn (CVal (HpRel _)   _)      = True
 192 mixedTypeLocn other                     = False -- All the rest
 193 \end{code}
 194
 195 @mixedPtrLocn@ tells whether an amode identifies a
 196 location which can contain values of various pointer types.
 197
 198 \begin{code}
 199 mixedPtrLocn :: CAddrMode -> Bool
 200
 201 mixedPtrLocn (CVal (SpRel _)  _)        = True
 202 mixedPtrLocn other                      = False -- All the rest
 203 \end{code}
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 The following bits take ``raw'' Abstract~C, which may have all sorts of
 212 nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
 213 @CClosureInfos@ and code for switches are pulled out to the top level.
 214
 215 The various functions herein tend to produce
 216 \begin{enumerate}
 217 \item
 218 A {\em flattened} \tr{<something>} of interest for ``here'', and
 219 \item
 220 Some {\em unflattened} Abstract~C statements to be carried up to the
 221 top-level.  The only real reason (now) that it is unflattened is
 222 because it means the recursive flattening can be done in just one
 223 place rather than having to remember lots of places.
 224 \end{enumerate}
 225
 226 Care is taken to reduce the occurrence of forward references, while still
 227 keeping laziness a much as possible.  Essentially, this means that:
 228 \begin{itemize}
 229 \item
 230 {\em All} the top-level C statements resulting from flattening a
 231 particular AbsC statement (whether the latter is nested or not) appear
 232 before {\em any} of the code for a subsequent AbsC statement;
 233 \item
 234 but stuff nested within any AbsC statement comes
 235 out before the code for the statement itself.
 236 \end{itemize}
 237
 238 The ``stuff to be carried up'' always includes a label: a
 239 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
 240 @CCodeBlock@.  The latter turns into a C function, and is never
 241 actually produced by the code generator.  Rather it always starts life
 242 as a @CCodeBlock@ addressing mode; when such an addr mode is
 243 flattened, the ``tops'' stuff is a @CCodeBlock@.
 244
 245 \begin{code}
 246 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
 247
 248 flattenAbsC us abs_C
 249   = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
 250     here `mkAbsCStmts` tops }
 251 \end{code}
 252
 253 %************************************************************************
 254 %*                                                                      *
 255 \subsubsection{Flattening monadery}
 256 %*                                                                      *
 257 %************************************************************************
 258
 259 The flattener is monadised.  It's just a @UniqueSupply@.
 260
 261 \begin{code}
 262 type FlatM result =  UniqSupply -> result
 263
 264 initFlt :: UniqSupply -> FlatM a -> a
 265
 266 initFlt init_us m = m init_us
 267
 268 {-# INLINE thenFlt #-}
 269 {-# INLINE returnFlt #-}
 270
 271 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
 272
 273 thenFlt expr cont us
 274   = case (splitUniqSupply us)   of { (s1, s2) ->
 275     case (expr s1)              of { result ->
 276     cont result s2 }}
 277
 278 returnFlt :: a -> FlatM a
 279 returnFlt result us = result
 280
 281 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
 282
 283 mapFlt f []     = returnFlt []
 284 mapFlt f (x:xs)
 285   = f x         `thenFlt` \ r  ->
 286     mapFlt f xs `thenFlt` \ rs ->
 287     returnFlt (r:rs)
 288
 289 mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
 290
 291 mapAndUnzipFlt f [] = returnFlt ([],[])
 292 mapAndUnzipFlt f (x:xs)
 293   = f x                 `thenFlt` \ (r1,  r2)  ->
 294     mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
 295     returnFlt (r1:rs1, r2:rs2)
 296
 297 getUniqFlt :: FlatM Unique
 298 getUniqFlt us = uniqFromSupply us
 299
 300 getUniqsFlt :: FlatM [Unique]
 301 getUniqsFlt us = uniqsFromSupply us
 302 \end{code}
 303
 304 %************************************************************************
 305 %*                                                                      *
 306 \subsubsection{Flattening the top level}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 \begin{code}
 311 flatAbsC :: AbstractC
 312          -> FlatM (AbstractC,   -- Stuff to put inline          [Both are fully
 313                    AbstractC)   -- Stuff to put at top level     flattened]
 314
 315 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
 316
 317 flatAbsC (AbsCStmts s1 s2)
 318   = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
 319     flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
 320     returnFlt (mkAbsCStmts inline_s1 inline_s2,
 321                mkAbsCStmts top_s1    top_s2)
 322
 323 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
 324   = flatAbsC slow               `thenFlt` \ (slow_heres, slow_tops) ->
 325     flat_maybe maybe_fast       `thenFlt` \ (fast_heres, fast_tops) ->
 326     returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
 327        CClosureInfoAndCode cl_info slow_heres fast_heres descr]
 328     )
 329
 330 flatAbsC (CCodeBlock lbl abs_C)
 331   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 332     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 333
 334 flatAbsC (CRetDirect uniq slow_code srt liveness)
 335   = flatAbsC slow_code          `thenFlt` \ (heres, tops) ->
 336     returnFlt (AbsCNop,
 337                 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
 338
 339 flatAbsC (CSwitch discrim alts deflt)
 340   = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 341     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 342     returnFlt (
 343       CSwitch discrim flat_alts flat_def_alt,
 344       mkAbstractCs (def_tops : flat_alts_tops)
 345     )
 346   where
 347     flat_alt (tag, absC)
 348       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 349         returnFlt ( (tag, alt_heres), alt_tops )
 350
 351 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
 352   |  is_dynamic                          -- Emit a typedef if its a dynamic call
 353      || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
 354   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
 355   where
 356     is_dynamic = isDynamicTarget target
 357
 358 flatAbsC stmt@(CSimultaneous abs_c)
 359   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 360     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 361     returnFlt (new_stmts_here, tops)
 362
 363 flatAbsC stmt@(CCheck macro amodes code)
 364   = flatAbsC code               `thenFlt` \ (code_here, code_tops) ->
 365     returnFlt (CCheck macro amodes code_here, code_tops)
 366
 367 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
 368 -- This is a HACK.
 369 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 370   | str == SLIT("TICK_CTR")     = returnFlt (AbsCNop, stmt)
 371   | otherwise                   = returnFlt (stmt, AbsCNop)
 372
 373 -- Some statements need no flattening at all:
 374 flatAbsC stmt@(CMacroStmt macro amodes)          = returnFlt (stmt, AbsCNop)
 375 flatAbsC stmt@(CCallProfCCMacro str amodes)      = returnFlt (stmt, AbsCNop)
 376 flatAbsC stmt@(CAssign dest source)              = returnFlt (stmt, AbsCNop)
 377 flatAbsC stmt@(CJump target)                     = returnFlt (stmt, AbsCNop)
 378 flatAbsC stmt@(CFallThrough target)              = returnFlt (stmt, AbsCNop)
 379 flatAbsC stmt@(CReturn target return_info)       = returnFlt (stmt, AbsCNop)
 380 flatAbsC stmt@(CInitHdr a b cc sz)               = returnFlt (stmt, AbsCNop)
 381 flatAbsC stmt@(CMachOpStmt res mop args m_vols)  = returnFlt (stmt, AbsCNop)
 382 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
 383                                                  = returnFlt (stmt, AbsCNop)
 384 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
 385    = dscCOpStmt (filter non_void_amode results) op
 386                 (filter non_void_amode args) vol_regs
 387                                 `thenFlt` \ simpl ->
 388      case simpl of
 389         COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt"   -- make sure we don't loop!
 390         other           -> flatAbsC other
 391      {-
 392         A gruesome hack for printing the names of inline primops when they
 393         are used.
 394                                   oink other
 395      where
 396         oink xxx
 397             = getUniqFlt `thenFlt` \ uu ->
 398               flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
 399
 400         moo uu op_str
 401            = COpStmt
 402                 []
 403                 (StgFCallOp
 404                     (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str)))
 405                                       defaultCCallConv PlaySafe))
 406                     uu
 407                 )
 408                 [CReg VoidReg]
 409                 []
 410         mktxt op_str
 411             = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
 412      -}
 413
 414 flatAbsC (CSequential abcs)
 415   = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
 416     returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
 417
 418
 419 -- Some statements only make sense at the top level, so we always float
 420 -- them.  This probably isn't necessary.
 421 flatAbsC stmt@(CStaticClosure _ _ _ _)          = returnFlt (AbsCNop, stmt)
 422 flatAbsC stmt@(CClosureTbl _)                   = returnFlt (AbsCNop, stmt)
 423 flatAbsC stmt@(CSRT _ _)                        = returnFlt (AbsCNop, stmt)
 424 flatAbsC stmt@(CBitmap _ _)                     = returnFlt (AbsCNop, stmt)
 425 flatAbsC stmt@(CCostCentreDecl _ _)             = returnFlt (AbsCNop, stmt)
 426 flatAbsC stmt@(CCostCentreStackDecl _)          = returnFlt (AbsCNop, stmt)
 427 flatAbsC stmt@(CSplitMarker)                    = returnFlt (AbsCNop, stmt)
 428 flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
 429 flatAbsC stmt@(CModuleInitBlock _ _)            = returnFlt (AbsCNop, stmt)
 430 \end{code}
 431
 432 \begin{code}
 433 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
 434 flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
 435 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
 436                           returnFlt (Just heres, tops)
 437 \end{code}
 438
 439 %************************************************************************
 440 %*                                                                      *
 441 \subsection[flat-simultaneous]{Doing things simultaneously}
 442 %*                                                                      *
 443 %************************************************************************
 444
 445 \begin{code}
 446 doSimultaneously :: AbstractC -> FlatM AbstractC
 447 \end{code}
 448
 449 Generate code to perform the @CAssign@s and @COpStmt@s in the
 450 input simultaneously, using temporary variables when necessary.
 451
 452 We use the strongly-connected component algorithm, in which
 453         * the vertices are the statements
 454         * an edge goes from s1 to s2 iff
 455                 s1 assigns to something s2 uses
 456           that is, if s1 should *follow* s2 in the final order
 457
 458 \begin{code}
 459 type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
 460                                  -- for fast comparison
 461
 462 doSimultaneously abs_c
 463   = let
 464         enlisted = en_list abs_c
 465     in
 466     case enlisted of -- it's often just one stmt
 467       []  -> returnFlt AbsCNop
 468       [x] -> returnFlt x
 469       _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
 470
 471 -- en_list puts all the assignments in a list, filtering out Nops and
 472 -- assignments which do nothing
 473 en_list AbsCNop                               = []
 474 en_list (AbsCStmts a1 a2)                     = en_list a1 ++ en_list a2
 475 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
 476 en_list other                                 = [other]
 477
 478 sameAmode :: CAddrMode -> CAddrMode -> Bool
 479 -- ToDo: Move this function, or make CAddrMode an instance of Eq
 480 -- At the moment we put in just enough to catch the cases we want:
 481 --      the second (destination) argument is always a CVal.
 482 sameAmode (CReg r1)                  (CReg r2)               = r1 == r2
 483 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)            = r1 ==# r2
 484 sameAmode other1                     other2                  = False
 485
 486 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
 487 doSimultaneously1 vertices
 488   = let
 489         edges = [ (vertex, key1, edges_from stmt1)
 490                 | vertex@(key1, stmt1) <- vertices
 491                 ]
 492         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 493                                     stmt1 `should_follow` stmt2
 494                            ]
 495         components = stronglyConnComp edges
 496
 497         -- do_components deal with one strongly-connected component
 498                 -- Not cyclic, or singleton?  Just do it
 499         do_component (AcyclicSCC (n,abs_c))  = returnFlt abs_c
 500         do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
 501
 502                 -- Cyclic?  Then go via temporaries.  Pick one to
 503                 -- break the loop and try again with the rest.
 504         do_component (CyclicSCC ((n,first_stmt) : rest))
 505           = doSimultaneously1 rest      `thenFlt` \ abs_cs ->
 506             go_via_temps first_stmt     `thenFlt` \ (to_temps, from_temps) ->
 507             returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
 508
 509         go_via_temps (CAssign dest src)
 510           = getUniqFlt                  `thenFlt` \ uniq ->
 511             let
 512                 the_temp = CTemp uniq (getAmodeRep dest)
 513             in
 514             returnFlt (CAssign the_temp src, CAssign dest the_temp)
 515
 516         go_via_temps (COpStmt dests op srcs vol_regs)
 517           = getUniqsFlt                 `thenFlt` \ uniqs ->
 518             let
 519                 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 520             in
 521             returnFlt (COpStmt the_temps op srcs vol_regs,
 522                        mkAbstractCs (zipWith CAssign dests the_temps))
 523     in
 524     mapFlt do_component components `thenFlt` \ abs_cs ->
 525     returnFlt (mkAbstractCs abs_cs)
 526
 527   where
 528     should_follow :: AbstractC -> AbstractC -> Bool
 529     (CAssign dest1 _) `should_follow` (CAssign _ src2)
 530       = dest1 `conflictsWith` src2
 531     (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
 532       = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
 533     (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
 534       = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
 535     (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
 536       = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
 537 \end{code}
 538
 539 @conflictsWith@ tells whether an assignment to its first argument will
 540 screw up an access to its second.
 541
 542 \begin{code}
 543 conflictsWith :: CAddrMode -> CAddrMode -> Bool
 544 (CReg reg1)        `conflictsWith` (CReg reg2)          = reg1 == reg2
 545 (CReg reg)         `conflictsWith` (CVal reg_rel _)     = reg `regConflictsWithRR` reg_rel
 546 (CReg reg)         `conflictsWith` (CAddr reg_rel)      = reg `regConflictsWithRR` reg_rel
 547 (CTemp u1 _)       `conflictsWith` (CTemp u2 _)         = u1 == u2
 548 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
 549   = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
 550
 551 other1            `conflictsWith` other2                = False
 552 -- CAddr and literals are impossible on the LHS of an assignment
 553
 554 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 555
 556 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1)    = True
 557 regConflictsWithRR Sp   (SpRel _)       = True
 558 regConflictsWithRR Hp   (HpRel _)       = True
 559 regConflictsWithRR _    _               = False
 560
 561 rrConflictsWithRR :: Int -> Int                 -- Sizes of two things
 562                   -> RegRelative -> RegRelative -- The two amodes
 563                   -> Bool
 564
 565 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
 566   where
 567     s1 = iUnbox s1b
 568     s2 = iUnbox s2b
 569
 570     rr (SpRel o1)    (SpRel o2)
 571         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 572         | s1 ==# (_ILIT 1)  && s2 ==# (_ILIT 1) = o1 ==# o2
 573         | otherwise          = (o1 +# s1) >=# o2  &&
 574                                (o2 +# s2) >=# o1
 575
 576     rr (NodeRel o1)      (NodeRel o2)
 577         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 578         | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
 579         | otherwise          = True             -- Give up
 580
 581     rr (HpRel _)         (HpRel _)    = True    -- Give up (ToDo)
 582
 583     rr other1            other2       = False
 584 \end{code}
 585
 586 %************************************************************************
 587 %*                                                                      *
 588 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 \begin{code}
 593
 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 (Just1 t_hw_shift)
 613                           MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
 614          a_hw_mask1
 615             = CMachOpStmt (Just1 t_hw_mask1)
 616                           MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
 617          a_hw_mask2
 618             = CMachOpStmt (Just1 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 (Just1 res) MO_Nat_And [arg, t_hw_mask2] Nothing
 624               ]
 625 #        else
 626             = CSequential [ a_hw_shift,
 627                  CMachOpStmt (Just1 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 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 641 mkDerefOff rep base off
 642    | off == 0   -- optimisation
 643    = CMem rep base
 644    | otherwise
 645    = CMem rep (CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep))
 646
 647 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 648 mkNoDerefOff rep base off
 649    = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
 650
 651 -- Sigh.  This is done in 3 seperate places.  Should be
 652 -- commoned up (here, in pprAbsC of COpStmt, and presumably
 653 -- somewhere in the NCG).
 654 non_void_amode amode
 655    = case getAmodeRep amode of
 656         VoidRep -> False
 657         k       -> True
 658
 659 doIndexOffForeignObjOp rep res addr idx
 660    = Just (Just1 res, MO_ReadOSBI fixedHdrSize rep, [addr,idx])
 661
 662 doIndexOffAddrOp rep res addr idx
 663    = Just (Just1 res, MO_ReadOSBI 0 rep, [addr,idx])
 664
 665 doIndexByteArrayOp rep res addr idx
 666    = Just (Just1 res, MO_ReadOSBI arrWordsHdrSize rep, [addr,idx])
 667
 668 doWriteOffAddrOp rep addr idx val
 669    = Just (Just0, MO_WriteOSBI 0 rep, [addr,idx,val])
 670
 671 doWriteByteArrayOp rep addr idx val
 672    = Just (Just0, MO_WriteOSBI arrWordsHdrSize rep, [addr,idx,val])
 673
 674 -- Simple dyadic op but one for which we need to cast first arg to
 675 -- be sure of correctness
 676 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
 677    = mkTemp cast_arg1_to                `thenFlt` \ arg1casted ->
 678      (returnFlt . CSequential) [
 679         CAssign arg1casted arg1,
 680         CMachOpStmt (Just1 res) mop [arg1casted,arg2]
 681            (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 682      ]
 683
 684 ------------------------------------------------------------------------------
 685
 686 dscCOpStmt :: [CAddrMode]       -- Results
 687            -> PrimOp
 688            -> [CAddrMode]       -- Arguments
 689            -> [MagicId]         -- Potentially volatile/live registers
 690                                 -- (to save/restore around the op)
 691            -> FlatM AbstractC
 692
 693 -- #define parzh(r,node) r = 1
 694 dscCOpStmt [res] ParOp [arg] vols
 695    = returnFlt
 696         (CAssign res (CLit (mkMachInt 1)))
 697
 698 -- #define readMutVarzh(r,a)     r=(P_)(((StgMutVar *)(a))->var)
 699 dscCOpStmt [res] ReadMutVarOp [mutv] vols
 700    = returnFlt
 701         (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
 702
 703 -- #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 704 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
 705    = returnFlt
 706         (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
 707
 708
 709 -- #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 710 -- #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 711 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
 712    = returnFlt
 713         (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
 714
 715 -- #define writeForeignObjzh(res,datum) \
 716 --    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 717 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
 718    = returnFlt
 719         (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
 720
 721
 722 -- #define sizzeofByteArrayzh(r,a) \
 723 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 724 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 725    = mkTemp WordRep                     `thenFlt` \ w ->
 726      (returnFlt . CSequential) [
 727         CAssign w (mkDerefOff WordRep arg fixedHdrSize),
 728         CMachOpStmt (Just1 w)
 729            MO_NatU_Mul [w, CBytesPerWord] (Just vols),
 730         CAssign res w
 731      ]
 732
 733 -- #define sizzeofMutableByteArrayzh(r,a) \
 734 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
 735 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
 736    = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 737
 738
 739 -- #define touchzh(o)                  /* nothing */
 740 dscCOpStmt [] TouchOp [arg] vols
 741    = returnFlt AbsCNop
 742
 743 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 744 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
 745    = mkTemp PtrRep                      `thenFlt` \ ptr ->
 746      (returnFlt . CSequential) [
 747          CMachOpStmt (Just1 ptr) MO_NatU_to_NatP [arg] Nothing,
 748          CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
 749          CAssign res ptr
 750      ]
 751
 752 -- #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 753 dscCOpStmt [res] StableNameToIntOp [arg] vols
 754    = returnFlt
 755         (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
 756
 757 -- #define eqStableNamezh(r,sn1,sn2)                                    \
 758 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 759 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
 760    = mkTemps [WordRep, WordRep]         `thenFlt` \ [sn1,sn2] ->
 761      (returnFlt . CSequential) [
 762         CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
 763         CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
 764         CMachOpStmt (Just1 res) MO_Nat_Eq [sn1,sn2] Nothing
 765      ]
 766
 767 -- #define addrToHValuezh(r,a) r=(P_)a
 768 dscCOpStmt [res] AddrToHValueOp [arg] vols
 769    = returnFlt
 770         (CAssign res arg)
 771
 772 -- #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 773 dscCOpStmt [res] DataToTagOp [arg] vols
 774    = mkTemps [PtrRep, WordRep]          `thenFlt` \ [t_infoptr, t_theword] ->
 775      mkHalfWord_HIADDR res t_theword    `thenFlt` \ select_ops ->
 776      (returnFlt . CSequential) [
 777         CAssign t_infoptr (mkDerefOff PtrRep arg 0),
 778         CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
 779         select_ops
 780      ]
 781
 782
 783 {- Freezing arrays-of-ptrs requires changing an info table, for the
 784    benefit of the generational collector.  It needs to scavenge mutable
 785    objects, even if they are in old space.  When they become immutable,
 786    they can be removed from this scavenge list.  -}
 787
 788 -- #define unsafeFreezzeArrayzh(r,a)                                    \
 789 --      {                                                               \
 790 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 791 --      r = a;                                                          \
 792 --      }
 793 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
 794    = (returnFlt . CSequential) [
 795         CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
 796         CAssign res arg
 797      ]
 798
 799 -- #define unsafeFreezzeByteArrayzh(r,a)        r=(a)
 800 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
 801    = returnFlt
 802         (CAssign res arg)
 803
 804 -- This ought to be trivial, but it's difficult to insert the casts
 805 -- required to keep the C compiler happy.
 806 dscCOpStmt [r] AddrRemOp [a1,a2] vols
 807    = mkTemp WordRep                     `thenFlt` \ a1casted ->
 808      (returnFlt . CSequential) [
 809         CMachOpStmt (Just1 a1casted) MO_NatP_to_NatU [a1] Nothing,
 810         CMachOpStmt (Just1 r) MO_NatU_Rem [a1casted,a2] Nothing
 811      ]
 812
 813 -- not handled by translateOp because they need casts
 814 dscCOpStmt [r] SllOp [a1,a2] vols
 815    = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
 816 dscCOpStmt [r] SrlOp [a1,a2] vols
 817    = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
 818
 819 dscCOpStmt [r] ISllOp [a1,a2] vols
 820    = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
 821 dscCOpStmt [r] ISrlOp [a1,a2] vols
 822    = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
 823 dscCOpStmt [r] ISraOp [a1,a2] vols
 824    = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
 825
 826
 827 -- Handle all others as simply as possible.
 828 dscCOpStmt ress op args vols
 829    = case translateOp ress op args of
 830         Nothing
 831            -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
 832         Just (maybe_res, mop, args)
 833            -> returnFlt (
 834                  CMachOpStmt maybe_res mop args
 835                     (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 836               )
 837
 838
 839
 840 translateOp [r] ReadArrayOp [obj,ix]
 841    = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
 842 translateOp [r] IndexArrayOp [obj,ix]
 843    = Just (Just1 r, MO_ReadOSBI arrPtrsHdrSize PtrRep, [obj,ix])
 844 translateOp [] WriteArrayOp [obj,ix,v]
 845    = Just (Just0, MO_WriteOSBI arrPtrsHdrSize PtrRep, [obj,ix,v])
 846
 847 -- IndexXXXoffForeignObj
 848
 849 translateOp [r] IndexOffForeignObjOp_Char [a,i]  = doIndexOffForeignObjOp Word8Rep r a i
 850 translateOp [r] IndexOffForeignObjOp_WideChar [a,i]  = doIndexOffForeignObjOp Word32Rep r a i
 851 translateOp [r] IndexOffForeignObjOp_Int [a,i]  = doIndexOffForeignObjOp IntRep r a i
 852 translateOp [r] IndexOffForeignObjOp_Word [a,i]  = doIndexOffForeignObjOp WordRep r a i
 853 translateOp [r] IndexOffForeignObjOp_Addr [a,i]  = doIndexOffForeignObjOp AddrRep r a i
 854 translateOp [r] IndexOffForeignObjOp_Float [a,i]  = doIndexOffForeignObjOp FloatRep r a i
 855 translateOp [r] IndexOffForeignObjOp_Double [a,i]  = doIndexOffForeignObjOp DoubleRep r a i
 856 translateOp [r] IndexOffForeignObjOp_StablePtr [a,i]  = doIndexOffForeignObjOp StablePtrRep r a i
 857
 858 translateOp [r] IndexOffForeignObjOp_Int8  [a,i] = doIndexOffForeignObjOp Int8Rep  r a i
 859 translateOp [r] IndexOffForeignObjOp_Int16 [a,i] = doIndexOffForeignObjOp Int16Rep r a i
 860 translateOp [r] IndexOffForeignObjOp_Int32 [a,i] = doIndexOffForeignObjOp Int32Rep r a i
 861 translateOp [r] IndexOffForeignObjOp_Int64 [a,i] = doIndexOffForeignObjOp Int64Rep r a i
 862
 863 translateOp [r] IndexOffForeignObjOp_Word8  [a,i] = doIndexOffForeignObjOp Word8Rep  r a i
 864 translateOp [r] IndexOffForeignObjOp_Word16 [a,i] = doIndexOffForeignObjOp Word16Rep r a i
 865 translateOp [r] IndexOffForeignObjOp_Word32 [a,i] = doIndexOffForeignObjOp Word32Rep r a i
 866 translateOp [r] IndexOffForeignObjOp_Word64 [a,i] = doIndexOffForeignObjOp Word64Rep r a i
 867
 868 -- IndexXXXoffAddr
 869
 870 translateOp [r] IndexOffAddrOp_Char [a,i]  = doIndexOffAddrOp Word8Rep r a i
 871 translateOp [r] IndexOffAddrOp_WideChar [a,i]  = doIndexOffAddrOp Word32Rep r a i
 872 translateOp [r] IndexOffAddrOp_Int [a,i]  = doIndexOffAddrOp IntRep r a i
 873 translateOp [r] IndexOffAddrOp_Word [a,i]  = doIndexOffAddrOp WordRep r a i
 874 translateOp [r] IndexOffAddrOp_Addr [a,i]  = doIndexOffAddrOp AddrRep r a i
 875 translateOp [r] IndexOffAddrOp_Float [a,i]  = doIndexOffAddrOp FloatRep r a i
 876 translateOp [r] IndexOffAddrOp_Double [a,i]  = doIndexOffAddrOp DoubleRep r a i
 877 translateOp [r] IndexOffAddrOp_StablePtr [a,i]  = doIndexOffAddrOp StablePtrRep r a i
 878
 879 translateOp [r] IndexOffAddrOp_Int8  [a,i] = doIndexOffAddrOp Int8Rep  r a i
 880 translateOp [r] IndexOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
 881 translateOp [r] IndexOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
 882 translateOp [r] IndexOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
 883
 884 translateOp [r] IndexOffAddrOp_Word8  [a,i] = doIndexOffAddrOp Word8Rep  r a i
 885 translateOp [r] IndexOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
 886 translateOp [r] IndexOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
 887 translateOp [r] IndexOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
 888
 889 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 890
 891 translateOp [r] ReadOffAddrOp_Char [a,i]  = doIndexOffAddrOp Word8Rep r a i
 892 translateOp [r] ReadOffAddrOp_WideChar [a,i]  = doIndexOffAddrOp Word32Rep r a i
 893 translateOp [r] ReadOffAddrOp_Int [a,i]  = doIndexOffAddrOp IntRep r a i
 894 translateOp [r] ReadOffAddrOp_Word [a,i]  = doIndexOffAddrOp WordRep r a i
 895 translateOp [r] ReadOffAddrOp_Addr [a,i]  = doIndexOffAddrOp AddrRep r a i
 896 translateOp [r] ReadOffAddrOp_Float [a,i]  = doIndexOffAddrOp FloatRep r a i
 897 translateOp [r] ReadOffAddrOp_Double [a,i]  = doIndexOffAddrOp DoubleRep r a i
 898 translateOp [r] ReadOffAddrOp_StablePtr [a,i]  = doIndexOffAddrOp StablePtrRep r a i
 899
 900 translateOp [r] ReadOffAddrOp_Int8  [a,i] = doIndexOffAddrOp Int8Rep  r a i
 901 translateOp [r] ReadOffAddrOp_Int16 [a,i] = doIndexOffAddrOp Int16Rep r a i
 902 translateOp [r] ReadOffAddrOp_Int32 [a,i] = doIndexOffAddrOp Int32Rep r a i
 903 translateOp [r] ReadOffAddrOp_Int64 [a,i] = doIndexOffAddrOp Int64Rep r a i
 904
 905 translateOp [r] ReadOffAddrOp_Word8  [a,i] = doIndexOffAddrOp Word8Rep  r a i
 906 translateOp [r] ReadOffAddrOp_Word16 [a,i] = doIndexOffAddrOp Word16Rep r a i
 907 translateOp [r] ReadOffAddrOp_Word32 [a,i] = doIndexOffAddrOp Word32Rep r a i
 908 translateOp [r] ReadOffAddrOp_Word64 [a,i] = doIndexOffAddrOp Word64Rep r a i
 909
 910 -- WriteXXXoffAddr
 911
 912 translateOp [] WriteOffAddrOp_Char [a,i,x]  = doWriteOffAddrOp Word8Rep a i x
 913 translateOp [] WriteOffAddrOp_WideChar [a,i,x]  = doWriteOffAddrOp Word32Rep a i x
 914 translateOp [] WriteOffAddrOp_Int [a,i,x]  = doWriteOffAddrOp IntRep a i x
 915 translateOp [] WriteOffAddrOp_Word [a,i,x]  = doWriteOffAddrOp WordRep a i x
 916 translateOp [] WriteOffAddrOp_Addr [a,i,x]  = doWriteOffAddrOp AddrRep a i x
 917 translateOp [] WriteOffAddrOp_Float [a,i,x]  = doWriteOffAddrOp FloatRep a i x
 918 translateOp [] WriteOffAddrOp_ForeignObj [a,i,x]  = doWriteOffAddrOp ForeignObjRep a i x
 919 translateOp [] WriteOffAddrOp_Double [a,i,x]  = doWriteOffAddrOp DoubleRep a i x
 920 translateOp [] WriteOffAddrOp_StablePtr [a,i,x]  = doWriteOffAddrOp StablePtrRep a i x
 921
 922 translateOp [] WriteOffAddrOp_Int8  [a,i,x] = doWriteOffAddrOp Int8Rep  a i x
 923 translateOp [] WriteOffAddrOp_Int16 [a,i,x] = doWriteOffAddrOp Int16Rep a i x
 924 translateOp [] WriteOffAddrOp_Int32 [a,i,x] = doWriteOffAddrOp Int32Rep a i x
 925 translateOp [] WriteOffAddrOp_Int64 [a,i,x] = doWriteOffAddrOp Int64Rep a i x
 926
 927 translateOp [] WriteOffAddrOp_Word8  [a,i,x] = doWriteOffAddrOp Word8Rep  a i x
 928 translateOp [] WriteOffAddrOp_Word16 [a,i,x] = doWriteOffAddrOp Word16Rep a i x
 929 translateOp [] WriteOffAddrOp_Word32 [a,i,x] = doWriteOffAddrOp Word32Rep a i x
 930 translateOp [] WriteOffAddrOp_Word64 [a,i,x] = doWriteOffAddrOp Word64Rep a i x
 931
 932 -- IndexXXXArray
 933
 934 translateOp [r] IndexByteArrayOp_Char [a,i]  = doIndexByteArrayOp Word8Rep r a i
 935 translateOp [r] IndexByteArrayOp_WideChar [a,i]  = doIndexByteArrayOp Word32Rep r a i
 936 translateOp [r] IndexByteArrayOp_Int [a,i]  = doIndexByteArrayOp IntRep r a i
 937 translateOp [r] IndexByteArrayOp_Word [a,i]  = doIndexByteArrayOp WordRep r a i
 938 translateOp [r] IndexByteArrayOp_Addr [a,i]  = doIndexByteArrayOp AddrRep r a i
 939 translateOp [r] IndexByteArrayOp_Float [a,i]  = doIndexByteArrayOp FloatRep r a i
 940 translateOp [r] IndexByteArrayOp_Double [a,i]  = doIndexByteArrayOp DoubleRep r a i
 941 translateOp [r] IndexByteArrayOp_StablePtr [a,i]  = doIndexByteArrayOp StablePtrRep r a i
 942
 943 translateOp [r] IndexByteArrayOp_Int8  [a,i] = doIndexByteArrayOp Int8Rep  r a i
 944 translateOp [r] IndexByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep  r a i
 945 translateOp [r] IndexByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep  r a i
 946 translateOp [r] IndexByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep  r a i
 947
 948 translateOp [r] IndexByteArrayOp_Word8  [a,i] = doIndexByteArrayOp Word8Rep  r a i
 949 translateOp [r] IndexByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep  r a i
 950 translateOp [r] IndexByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep  r a i
 951 translateOp [r] IndexByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep  r a i
 952
 953 -- ReadXXXArray, identical to IndexXXXArray.
 954
 955 translateOp [r] ReadByteArrayOp_Char [a,i]  = doIndexByteArrayOp Word8Rep r a i
 956 translateOp [r] ReadByteArrayOp_WideChar [a,i]  = doIndexByteArrayOp Word32Rep r a i
 957 translateOp [r] ReadByteArrayOp_Int [a,i]  = doIndexByteArrayOp IntRep r a i
 958 translateOp [r] ReadByteArrayOp_Word [a,i]  = doIndexByteArrayOp WordRep r a i
 959 translateOp [r] ReadByteArrayOp_Addr [a,i]  = doIndexByteArrayOp AddrRep r a i
 960 translateOp [r] ReadByteArrayOp_Float [a,i]  = doIndexByteArrayOp FloatRep r a i
 961 translateOp [r] ReadByteArrayOp_Double [a,i]  = doIndexByteArrayOp DoubleRep r a i
 962 translateOp [r] ReadByteArrayOp_StablePtr [a,i]  = doIndexByteArrayOp StablePtrRep r a i
 963
 964 translateOp [r] ReadByteArrayOp_Int8  [a,i] = doIndexByteArrayOp Int8Rep  r a i
 965 translateOp [r] ReadByteArrayOp_Int16 [a,i] = doIndexByteArrayOp Int16Rep  r a i
 966 translateOp [r] ReadByteArrayOp_Int32 [a,i] = doIndexByteArrayOp Int32Rep  r a i
 967 translateOp [r] ReadByteArrayOp_Int64 [a,i] = doIndexByteArrayOp Int64Rep  r a i
 968
 969 translateOp [r] ReadByteArrayOp_Word8  [a,i] = doIndexByteArrayOp Word8Rep  r a i
 970 translateOp [r] ReadByteArrayOp_Word16 [a,i] = doIndexByteArrayOp Word16Rep  r a i
 971 translateOp [r] ReadByteArrayOp_Word32 [a,i] = doIndexByteArrayOp Word32Rep  r a i
 972 translateOp [r] ReadByteArrayOp_Word64 [a,i] = doIndexByteArrayOp Word64Rep  r a i
 973
 974 -- WriteXXXArray
 975
 976 translateOp [] WriteByteArrayOp_Char [a,i,x]  = doWriteByteArrayOp Word8Rep a i x
 977 translateOp [] WriteByteArrayOp_WideChar [a,i,x]  = doWriteByteArrayOp Word32Rep a i x
 978 translateOp [] WriteByteArrayOp_Int [a,i,x]  = doWriteByteArrayOp IntRep a i x
 979 translateOp [] WriteByteArrayOp_Word [a,i,x]  = doWriteByteArrayOp WordRep a i x
 980 translateOp [] WriteByteArrayOp_Addr [a,i,x]  = doWriteByteArrayOp AddrRep a i x
 981 translateOp [] WriteByteArrayOp_Float [a,i,x]  = doWriteByteArrayOp FloatRep a i x
 982 translateOp [] WriteByteArrayOp_Double [a,i,x]  = doWriteByteArrayOp DoubleRep a i x
 983 translateOp [] WriteByteArrayOp_StablePtr [a,i,x]  = doWriteByteArrayOp StablePtrRep a i x
 984
 985 translateOp [] WriteByteArrayOp_Int8  [a,i,x] = doWriteByteArrayOp Int8Rep  a i x
 986 translateOp [] WriteByteArrayOp_Int16 [a,i,x] = doWriteByteArrayOp Int16Rep  a i x
 987 translateOp [] WriteByteArrayOp_Int32 [a,i,x] = doWriteByteArrayOp Int32Rep  a i x
 988 translateOp [] WriteByteArrayOp_Int64 [a,i,x] = doWriteByteArrayOp Int64Rep  a i x
 989
 990 translateOp [] WriteByteArrayOp_Word8  [a,i,x] = doWriteByteArrayOp Word8Rep  a i x
 991 translateOp [] WriteByteArrayOp_Word16 [a,i,x] = doWriteByteArrayOp Word16Rep  a i x
 992 translateOp [] WriteByteArrayOp_Word32 [a,i,x] = doWriteByteArrayOp Word32Rep  a i x
 993 translateOp [] WriteByteArrayOp_Word64 [a,i,x] = doWriteByteArrayOp Word64Rep  a i x
 994
 995 -- Native word signless ops
 996
 997 translateOp [r] IntAddOp       [a1,a2] = Just (Just1 r, MO_Nat_Add,        [a1,a2])
 998 translateOp [r] IntSubOp       [a1,a2] = Just (Just1 r, MO_Nat_Sub,        [a1,a2])
 999 translateOp [r] WordAddOp      [a1,a2] = Just (Just1 r, MO_Nat_Add,        [a1,a2])
1000 translateOp [r] WordSubOp      [a1,a2] = Just (Just1 r, MO_Nat_Sub,        [a1,a2])
1001 translateOp [r] AddrAddOp      [a1,a2] = Just (Just1 r, MO_Nat_Add,        [a1,a2])
1002 translateOp [r] AddrSubOp      [a1,a2] = Just (Just1 r, MO_Nat_Sub,        [a1,a2])
1003
1004 translateOp [r] IntEqOp        [a1,a2] = Just (Just1 r, MO_Nat_Eq,         [a1,a2])
1005 translateOp [r] IntNeOp        [a1,a2] = Just (Just1 r, MO_Nat_Ne,         [a1,a2])
1006 translateOp [r] WordEqOp       [a1,a2] = Just (Just1 r, MO_Nat_Eq,         [a1,a2])
1007 translateOp [r] WordNeOp       [a1,a2] = Just (Just1 r, MO_Nat_Ne,         [a1,a2])
1008 translateOp [r] AddrEqOp       [a1,a2] = Just (Just1 r, MO_Nat_Eq,         [a1,a2])
1009 translateOp [r] AddrNeOp       [a1,a2] = Just (Just1 r, MO_Nat_Ne,         [a1,a2])
1010
1011 translateOp [r] AndOp          [a1,a2] = Just (Just1 r, MO_Nat_And,        [a1,a2])
1012 translateOp [r] OrOp           [a1,a2] = Just (Just1 r, MO_Nat_Or,         [a1,a2])
1013 translateOp [r] XorOp          [a1,a2] = Just (Just1 r, MO_Nat_Xor,        [a1,a2])
1014 translateOp [r] NotOp          [a1]    = Just (Just1 r, MO_Nat_Not,        [a1])
1015
1016 -- Native word signed ops
1017
1018 translateOp [r] IntMulOp       [a1,a2] = Just (Just1 r, MO_NatS_Mul,       [a1,a2])
1019 translateOp [r] IntQuotOp      [a1,a2] = Just (Just1 r, MO_NatS_Quot,      [a1,a2])
1020 translateOp [r] IntRemOp       [a1,a2] = Just (Just1 r, MO_NatS_Rem,       [a1,a2])
1021 translateOp [r] IntNegOp       [a1]    = Just (Just1 r, MO_NatS_Neg,       [a1])
1022
1023 translateOp [r,c] IntAddCOp    [a1,a2] = Just (Just2 r c, MO_NatS_AddC,    [a1,a2])
1024 translateOp [r,c] IntSubCOp    [a1,a2] = Just (Just2 r c, MO_NatS_SubC,    [a1,a2])
1025 translateOp [r,c] IntMulCOp    [a1,a2] = Just (Just2 r c, MO_NatS_MulC,    [a1,a2])
1026
1027 translateOp [r] IntGeOp        [a1,a2] = Just (Just1 r, MO_NatS_Ge,        [a1,a2])
1028 translateOp [r] IntLeOp        [a1,a2] = Just (Just1 r, MO_NatS_Le,        [a1,a2])
1029 translateOp [r] IntGtOp        [a1,a2] = Just (Just1 r, MO_NatS_Gt,        [a1,a2])
1030 translateOp [r] IntLtOp        [a1,a2] = Just (Just1 r, MO_NatS_Lt,        [a1,a2])
1031
1032 -- Native word unsigned ops
1033
1034 translateOp [r] WordGeOp       [a1,a2] = Just (Just1 r, MO_NatU_Ge,        [a1,a2])
1035 translateOp [r] WordLeOp       [a1,a2] = Just (Just1 r, MO_NatU_Le,        [a1,a2])
1036 translateOp [r] WordGtOp       [a1,a2] = Just (Just1 r, MO_NatU_Gt,        [a1,a2])
1037 translateOp [r] WordLtOp       [a1,a2] = Just (Just1 r, MO_NatU_Lt,        [a1,a2])
1038
1039 translateOp [r] WordMulOp      [a1,a2] = Just (Just1 r, MO_NatU_Mul,       [a1,a2])
1040 translateOp [r] WordQuotOp     [a1,a2] = Just (Just1 r, MO_NatU_Quot,      [a1,a2])
1041 translateOp [r] WordRemOp      [a1,a2] = Just (Just1 r, MO_NatU_Rem,       [a1,a2])
1042
1043 translateOp [r] AddrGeOp       [a1,a2] = Just (Just1 r, MO_NatU_Ge,        [a1,a2])
1044 translateOp [r] AddrLeOp       [a1,a2] = Just (Just1 r, MO_NatU_Le,        [a1,a2])
1045 translateOp [r] AddrGtOp       [a1,a2] = Just (Just1 r, MO_NatU_Gt,        [a1,a2])
1046 translateOp [r] AddrLtOp       [a1,a2] = Just (Just1 r, MO_NatU_Lt,        [a1,a2])
1047
1048 -- 32-bit unsigned ops
1049
1050 translateOp [r] CharEqOp       [a1,a2] = Just (Just1 r, MO_32U_Eq,        [a1,a2])
1051 translateOp [r] CharNeOp       [a1,a2] = Just (Just1 r, MO_32U_Ne,        [a1,a2])
1052 translateOp [r] CharGeOp       [a1,a2] = Just (Just1 r, MO_32U_Ge,        [a1,a2])
1053 translateOp [r] CharLeOp       [a1,a2] = Just (Just1 r, MO_32U_Le,        [a1,a2])
1054 translateOp [r] CharGtOp       [a1,a2] = Just (Just1 r, MO_32U_Gt,        [a1,a2])
1055 translateOp [r] CharLtOp       [a1,a2] = Just (Just1 r, MO_32U_Lt,        [a1,a2])
1056
1057 -- Double ops
1058
1059 translateOp [r] DoubleEqOp     [a1,a2] = Just (Just1 r, MO_Dbl_Eq,      [a1,a2])
1060 translateOp [r] DoubleNeOp     [a1,a2] = Just (Just1 r, MO_Dbl_Ne,      [a1,a2])
1061 translateOp [r] DoubleGeOp     [a1,a2] = Just (Just1 r, MO_Dbl_Ge,      [a1,a2])
1062 translateOp [r] DoubleLeOp     [a1,a2] = Just (Just1 r, MO_Dbl_Le,      [a1,a2])
1063 translateOp [r] DoubleGtOp     [a1,a2] = Just (Just1 r, MO_Dbl_Gt,      [a1,a2])
1064 translateOp [r] DoubleLtOp     [a1,a2] = Just (Just1 r, MO_Dbl_Lt,      [a1,a2])
1065
1066 translateOp [r] DoubleAddOp    [a1,a2] = Just (Just1 r, MO_Dbl_Add,    [a1,a2])
1067 translateOp [r] DoubleSubOp    [a1,a2] = Just (Just1 r, MO_Dbl_Sub,    [a1,a2])
1068 translateOp [r] DoubleMulOp    [a1,a2] = Just (Just1 r, MO_Dbl_Mul,    [a1,a2])
1069 translateOp [r] DoubleDivOp    [a1,a2] = Just (Just1 r, MO_Dbl_Div,    [a1,a2])
1070 translateOp [r] DoublePowerOp  [a1,a2] = Just (Just1 r, MO_Dbl_Pwr,    [a1,a2])
1071
1072 translateOp [r] DoubleSinOp    [a1]    = Just (Just1 r, MO_Dbl_Sin,    [a1])
1073 translateOp [r] DoubleCosOp    [a1]    = Just (Just1 r, MO_Dbl_Cos,    [a1])
1074 translateOp [r] DoubleTanOp    [a1]    = Just (Just1 r, MO_Dbl_Tan,    [a1])
1075 translateOp [r] DoubleSinhOp   [a1]    = Just (Just1 r, MO_Dbl_Sinh,   [a1])
1076 translateOp [r] DoubleCoshOp   [a1]    = Just (Just1 r, MO_Dbl_Cosh,   [a1])
1077 translateOp [r] DoubleTanhOp   [a1]    = Just (Just1 r, MO_Dbl_Tanh,   [a1])
1078 translateOp [r] DoubleAsinOp   [a1]    = Just (Just1 r, MO_Dbl_Asin,    [a1])
1079 translateOp [r] DoubleAcosOp   [a1]    = Just (Just1 r, MO_Dbl_Acos,    [a1])
1080 translateOp [r] DoubleAtanOp   [a1]    = Just (Just1 r, MO_Dbl_Atan,    [a1])
1081 translateOp [r] DoubleLogOp    [a1]    = Just (Just1 r, MO_Dbl_Log,    [a1])
1082 translateOp [r] DoubleExpOp    [a1]    = Just (Just1 r, MO_Dbl_Exp,    [a1])
1083 translateOp [r] DoubleSqrtOp   [a1]    = Just (Just1 r, MO_Dbl_Sqrt,    [a1])
1084 translateOp [r] DoubleNegOp    [a1]    = Just (Just1 r, MO_Dbl_Neg,    [a1])
1085
1086 -- Float ops
1087
1088 translateOp [r] FloatEqOp     [a1,a2] = Just (Just1 r, MO_Flt_Eq,      [a1,a2])
1089 translateOp [r] FloatNeOp     [a1,a2] = Just (Just1 r, MO_Flt_Ne,      [a1,a2])
1090 translateOp [r] FloatGeOp     [a1,a2] = Just (Just1 r, MO_Flt_Ge,      [a1,a2])
1091 translateOp [r] FloatLeOp     [a1,a2] = Just (Just1 r, MO_Flt_Le,      [a1,a2])
1092 translateOp [r] FloatGtOp     [a1,a2] = Just (Just1 r, MO_Flt_Gt,      [a1,a2])
1093 translateOp [r] FloatLtOp     [a1,a2] = Just (Just1 r, MO_Flt_Lt,      [a1,a2])
1094
1095 translateOp [r] FloatAddOp    [a1,a2] = Just (Just1 r, MO_Flt_Add,    [a1,a2])
1096 translateOp [r] FloatSubOp    [a1,a2] = Just (Just1 r, MO_Flt_Sub,    [a1,a2])
1097 translateOp [r] FloatMulOp    [a1,a2] = Just (Just1 r, MO_Flt_Mul,    [a1,a2])
1098 translateOp [r] FloatDivOp    [a1,a2] = Just (Just1 r, MO_Flt_Div,    [a1,a2])
1099 translateOp [r] FloatPowerOp  [a1,a2] = Just (Just1 r, MO_Flt_Pwr,    [a1,a2])
1100
1101 translateOp [r] FloatSinOp    [a1]    = Just (Just1 r, MO_Flt_Sin,    [a1])
1102 translateOp [r] FloatCosOp    [a1]    = Just (Just1 r, MO_Flt_Cos,    [a1])
1103 translateOp [r] FloatTanOp    [a1]    = Just (Just1 r, MO_Flt_Tan,    [a1])
1104 translateOp [r] FloatSinhOp   [a1]    = Just (Just1 r, MO_Flt_Sinh,   [a1])
1105 translateOp [r] FloatCoshOp   [a1]    = Just (Just1 r, MO_Flt_Cosh,   [a1])
1106 translateOp [r] FloatTanhOp   [a1]    = Just (Just1 r, MO_Flt_Tanh,   [a1])
1107 translateOp [r] FloatAsinOp   [a1]    = Just (Just1 r, MO_Flt_Asin,    [a1])
1108 translateOp [r] FloatAcosOp   [a1]    = Just (Just1 r, MO_Flt_Acos,    [a1])
1109 translateOp [r] FloatAtanOp   [a1]    = Just (Just1 r, MO_Flt_Atan,    [a1])
1110 translateOp [r] FloatLogOp    [a1]    = Just (Just1 r, MO_Flt_Log,    [a1])
1111 translateOp [r] FloatExpOp    [a1]    = Just (Just1 r, MO_Flt_Exp,    [a1])
1112 translateOp [r] FloatSqrtOp   [a1]    = Just (Just1 r, MO_Flt_Sqrt,    [a1])
1113 translateOp [r] FloatNegOp    [a1]    = Just (Just1 r, MO_Flt_Neg,    [a1])
1114
1115 -- Conversions
1116
1117 translateOp [r] Int2DoubleOp [a1]    = Just (Just1 r, MO_NatS_to_Dbl,    [a1])
1118 translateOp [r] Double2IntOp [a1]    = Just (Just1 r, MO_Dbl_to_NatS,    [a1])
1119
1120 translateOp [r] Int2FloatOp  [a1]    = Just (Just1 r, MO_NatS_to_Flt,    [a1])
1121 translateOp [r] Float2IntOp  [a1]    = Just (Just1 r, MO_Flt_to_NatS,    [a1])
1122
1123 translateOp [r] Float2DoubleOp [a1]    = Just (Just1 r, MO_Flt_to_Dbl,    [a1])
1124 translateOp [r] Double2FloatOp [a1]    = Just (Just1 r, MO_Dbl_to_Flt,    [a1])
1125
1126 translateOp [r] Int2WordOp   [a1]    = Just (Just1 r, MO_NatS_to_NatU,   [a1])
1127 translateOp [r] Word2IntOp   [a1]    = Just (Just1 r, MO_NatU_to_NatS,   [a1])
1128
1129 translateOp [r] Int2AddrOp   [a1]    = Just (Just1 r, MO_NatS_to_NatP,   [a1])
1130 translateOp [r] Addr2IntOp   [a1]    = Just (Just1 r, MO_NatP_to_NatS,   [a1])
1131
1132 translateOp [r] OrdOp    [a1]    = Just (Just1 r, MO_32U_to_NatS,    [a1])
1133 translateOp [r] ChrOp    [a1]    = Just (Just1 r, MO_NatS_to_32U,    [a1])
1134
1135 translateOp [r] Narrow8IntOp   [a1]    = Just (Just1 r, MO_8S_to_NatS,    [a1])
1136 translateOp [r] Narrow16IntOp  [a1]    = Just (Just1 r, MO_16S_to_NatS,    [a1])
1137 translateOp [r] Narrow32IntOp  [a1]    = Just (Just1 r, MO_32S_to_NatS,    [a1])
1138
1139 translateOp [r] Narrow8WordOp   [a1]    = Just (Just1 r, MO_8U_to_NatU,    [a1])
1140 translateOp [r] Narrow16WordOp  [a1]    = Just (Just1 r, MO_16U_to_NatU,    [a1])
1141 translateOp [r] Narrow32WordOp  [a1]    = Just (Just1 r, MO_32U_to_NatU,    [a1])
1142
1143 translateOp [r] SameMutVarOp   [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1144 translateOp [r] SameMVarOp     [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1145 translateOp [r] SameMutableArrayOp  [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1146 translateOp [r] SameMutableByteArrayOp [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1147 translateOp [r] EqForeignObj [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1148 translateOp [r] EqStablePtrOp [a1,a2]  = Just (Just1 r, MO_Nat_Eq,    [a1,a2])
1149
1150 translateOp _ _ _ = Nothing
1151
1152 \end{code}