ghc/compiler/nativeGen/Stix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module Stix (
   7         CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..),
   8         StixStmt(..), mkStAssign, StixStmtList,
   9         pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
  10         stixStmt_CountTempUses, stixStmt_Subst,
  11         liftStrings, repOfStixExpr,
  12         DestInfo(..), hasDestInfo,
  13
  14         stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
  15         stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
  16         stgCurrentTSO, stgCurrentNursery,
  17
  18         fixedHS, arrWordsHS, arrPtrsHS,
  19
  20         NatM, initNat, thenNat, returnNat,
  21         mapNat, mapAndUnzipNat, mapAccumLNat,
  22         getUniqueNat, getDeltaNat, setDeltaNat,
  23         NatM_State, mkNatM_State,
  24         uniqOfNatM_State, deltaOfNatM_State,
  25
  26         getUniqLabelNCG, getNatLabelNCG,
  27         ncgPrimopMoan,
  28
  29         -- Information about the target arch
  30         ncg_target_is_32bit
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import Ratio            ( Rational )
  36 import IOExts           ( unsafePerformIO )
  37 import IO               ( hPutStrLn, stderr )
  38
  39 import AbsCSyn          ( node, tagreg, MagicId(..) )
  40 import AbsCUtils        ( magicIdPrimRep )
  41 import ForeignCall      ( CCallConv )
  42 import CLabel           ( mkAsmTempLabel, CLabel, pprCLabel )
  43 import PrimRep          ( PrimRep(..) )
  44 import MachOp           ( MachOp(..), pprMachOp, resultRepsOfMachOp )
  45 import Unique           ( Unique )
  46 import SMRep            ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
  47 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply,
  48                           UniqSM, thenUs, returnUs, getUniqueUs )
  49 import Constants        ( wORD_SIZE )
  50 import Outputable
  51 import FastTypes
  52 \end{code}
  53
  54 Two types, StixStmt and StixValue, define Stix.
  55
  56 \begin{code}
  57
  58 -- Non-value trees; ones executed for their side-effect.
  59 data StixStmt
  60
  61   = -- Directive for the assembler to change segment
  62     StSegment CodeSegment
  63
  64     -- Assembly-language comments
  65   | StComment FAST_STRING
  66
  67     -- Assignments are typed to determine size and register placement.
  68     -- Assign a value to a StixReg
  69   | StAssignReg PrimRep StixReg StixExpr
  70
  71     -- Assign a value to memory.  First tree indicates the address to be
  72     -- assigned to, so there is an implicit dereference here.
  73   | StAssignMem PrimRep StixExpr StixExpr -- dst, src
  74
  75     -- A simple assembly label that we might jump to.
  76   | StLabel CLabel
  77
  78     -- A function header and footer
  79   | StFunBegin CLabel
  80   | StFunEnd CLabel
  81
  82     -- An unconditional jump. This instruction may or may not jump
  83     -- out of the register allocation domain (basic block, more or
  84     -- less).  For correct register allocation when this insn is used
  85     -- to jump through a jump table, we optionally allow a list of
  86     -- the exact targets to be attached, so that the allocator can
  87     -- easily construct the exact flow edges leaving this insn.
  88     -- Dynamic targets are allowed.
  89   | StJump DestInfo StixExpr
  90
  91     -- A fall-through, from slow to fast
  92   | StFallThrough CLabel
  93
  94     -- A conditional jump. This instruction can be non-terminal :-)
  95     -- Only static, local, forward labels are allowed
  96   | StCondJump CLabel StixExpr
  97
  98     -- Raw data (as in an info table).
  99   | StData PrimRep [StixExpr]
 100     -- String which has been lifted to the top level (sigh).
 101   | StDataString FAST_STRING
 102
 103     -- A value computed only for its side effects; result is discarded
 104     -- (A handy trapdoor to allow CCalls with no results to appear as
 105     -- statements).
 106   | StVoidable StixExpr
 107
 108
 109 -- Helper fn to make Stix assignment statements where the
 110 -- lvalue masquerades as a StixExpr.  A kludge that should
 111 -- be done away with.
 112 mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
 113 mkStAssign rep (StReg reg) rhs
 114    = StAssignReg rep reg rhs
 115 mkStAssign rep (StInd rep' addr) rhs
 116    | rep `isCloseEnoughTo` rep'
 117    = StAssignMem rep addr rhs
 118    | otherwise
 119    = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
 120      --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
 121      StAssignMem rep addr rhs
 122      --)
 123      where
 124         isCloseEnoughTo r1 r2
 125            = r1 == r2 || (wordIsh r1 && wordIsh r2)
 126         wordIsh rep
 127            = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep,
 128                          RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep]
 129                         -- determined by looking at PrimRep.showPrimRep
 130
 131 -- Stix trees which denote a value.
 132 data StixExpr
 133   = -- Literals
 134     StInt       Integer     -- ** add Kind at some point
 135   | StFloat     Rational
 136   | StDouble    Rational
 137   | StString    FAST_STRING
 138   | StCLbl      CLabel      -- labels that we might index into
 139
 140     -- Abstract registers of various kinds
 141   | StReg StixReg
 142
 143     -- A typed offset from a base location
 144   | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
 145
 146     -- An indirection from an address to its contents.
 147   | StInd PrimRep StixExpr
 148
 149     -- Primitive Operations
 150   | StMachOp MachOp [StixExpr]
 151
 152     -- Calls to C functions
 153   | StCall FAST_STRING CCallConv PrimRep [StixExpr]
 154
 155
 156 -- What's the PrimRep of the value denoted by this StixExpr?
 157 repOfStixExpr :: StixExpr -> PrimRep
 158 repOfStixExpr (StInt _)       = IntRep
 159 repOfStixExpr (StFloat _)     = FloatRep
 160 repOfStixExpr (StDouble _)    = DoubleRep
 161 repOfStixExpr (StString _)    = PtrRep
 162 repOfStixExpr (StCLbl _)      = PtrRep
 163 repOfStixExpr (StReg reg)     = repOfStixReg reg
 164 repOfStixExpr (StIndex _ _ _) = PtrRep
 165 repOfStixExpr (StInd rep _)   = rep
 166 repOfStixExpr (StCall target conv retrep args) = retrep
 167 repOfStixExpr (StMachOp mop args)
 168    = case resultRepsOfMachOp mop of
 169         Just rep -> rep
 170         Nothing  -> pprPanic "repOfStixExpr:StMachOp" (pprMachOp mop)
 171
 172
 173 -- used by insnFuture in RegAllocInfo.lhs
 174 data DestInfo
 175    = NoDestInfo             -- no supplied dests; infer from context
 176    | DestInfo [CLabel]      -- precisely these dests and no others
 177
 178 hasDestInfo NoDestInfo   = False
 179 hasDestInfo (DestInfo _) = True
 180
 181 pprDests :: DestInfo -> SDoc
 182 pprDests NoDestInfo      = text "NoDestInfo"
 183 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
 184
 185
 186 pprStixStmts :: [StixStmt] -> SDoc
 187 pprStixStmts ts
 188   = vcat [
 189        vcat (map pprStixStmt ts),
 190        char ' ',
 191        char ' '
 192     ]
 193
 194
 195 pprStixExpr :: StixExpr -> SDoc
 196 pprStixExpr t
 197    = case t of
 198        StCLbl lbl       -> pprCLabel lbl
 199        StInt i          -> (if i < 0 then parens else id) (integer i)
 200        StFloat rat      -> parens (text "Float" <+> rational rat)
 201        StDouble rat     -> parens (text "Double" <+> rational rat)
 202        StString str     -> parens (text "Str `" <> ptext str <> char '\'')
 203        StIndex k b o    -> parens (pprStixExpr b <+> char '+' <>
 204                                    ppr k <+> pprStixExpr o)
 205        StInd k t        -> ppr k <> char '[' <> pprStixExpr t <> char ']'
 206        StReg reg        -> pprStixReg reg
 207        StMachOp op args -> pprMachOp op
 208                            <> parens (hsep (punctuate comma (map pprStixExpr args)))
 209        StCall nm cc k args
 210                         -> parens (text "Call" <+> ptext nm <+>
 211                                    ppr cc <+> ppr k <+>
 212                                    hsep (map pprStixExpr args))
 213
 214 pprStixStmt :: StixStmt -> SDoc
 215 pprStixStmt t
 216    = case t of
 217        StSegment cseg   -> parens (ppCodeSegment cseg)
 218        StComment str    -> parens (text "Comment" <+> ptext str)
 219        StAssignReg pr reg rhs
 220                         -> pprStixReg reg <> text "  :=" <> ppr pr
 221                                           <> text "  " <> pprStixExpr rhs
 222        StAssignMem pr addr rhs
 223                         -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
 224                                   <> text "  :=" <> ppr pr
 225                                   <> text "  " <> pprStixExpr rhs
 226        StLabel ll       -> pprCLabel ll <+> char ':'
 227        StFunBegin ll    -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
 228        StFunEnd ll      -> parens (text "FunEnd" <+> pprCLabel ll)
 229        StJump dsts t    -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
 230        StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
 231        StCondJump l t   -> parens (text "JumpC" <+> pprCLabel l
 232                                                 <+> pprStixExpr t)
 233        StData k ds      -> parens (text "Data" <+> ppr k <+>
 234                                    hsep (map pprStixExpr ds))
 235        StDataString str -> parens (text "DataString" <+> ppr str)
 236        StVoidable expr  -> text "(void)" <+> pprStixExpr expr
 237 \end{code}
 238
 239 Stix registers can have two forms.  They {\em may} or {\em may not}
 240 map to real, machine-level registers.
 241
 242 \begin{code}
 243 data StixReg
 244   = StixMagicId MagicId -- Regs which are part of the abstract machine model
 245
 246   | StixTemp StixVReg   -- "Regs" which model local variables (CTemps) in
 247                         -- the abstract C.
 248
 249 pprStixReg (StixMagicId mid)  = ppMId mid
 250 pprStixReg (StixTemp temp)    = pprStixVReg temp
 251
 252 repOfStixReg (StixTemp (StixVReg u pr)) = pr
 253 repOfStixReg (StixMagicId mid)          = magicIdPrimRep mid
 254
 255 data StixVReg
 256    = StixVReg Unique PrimRep
 257
 258 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
 259
 260
 261
 262 ppMId BaseReg              = text "BaseReg"
 263 ppMId (VanillaReg kind n)  = hcat [ppr kind, text "IntReg(",
 264                                    int (iBox n), char ')']
 265 ppMId (FloatReg n)         = hcat [text "FltReg(", int (iBox n), char ')']
 266 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (iBox n), char ')']
 267 ppMId (LongReg kind n)     = hcat [ppr kind, text "LongReg(",
 268                                    int (iBox n), char ')']
 269 ppMId Sp                   = text "Sp"
 270 ppMId Su                   = text "Su"
 271 ppMId SpLim                = text "SpLim"
 272 ppMId Hp                   = text "Hp"
 273 ppMId HpLim                = text "HpLim"
 274 ppMId CurCostCentre        = text "CCC"
 275 ppMId VoidReg              = text "VoidReg"
 276 \end{code}
 277
 278 We hope that every machine supports the idea of data segment and text
 279 segment (or that it has no segments at all, and we can lump these
 280 together).
 281
 282 \begin{code}
 283 data CodeSegment
 284    = DataSegment
 285    | TextSegment
 286    | RoDataSegment
 287      deriving (Eq, Show)
 288
 289 ppCodeSegment = text . show
 290
 291 type StixStmtList = [StixStmt] -> [StixStmt]
 292 \end{code}
 293
 294 Stix Trees for STG registers:
 295 \begin{code}
 296 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 297         :: StixReg
 298
 299 stgBaseReg          = StixMagicId BaseReg
 300 stgNode             = StixMagicId node
 301 stgTagReg           = StixMagicId tagreg
 302 stgSp               = StixMagicId Sp
 303 stgSu               = StixMagicId Su
 304 stgSpLim            = StixMagicId SpLim
 305 stgHp               = StixMagicId Hp
 306 stgHpLim            = StixMagicId HpLim
 307 stgHpAlloc          = StixMagicId HpAlloc
 308 stgCurrentTSO       = StixMagicId CurrentTSO
 309 stgCurrentNursery   = StixMagicId CurrentNursery
 310 stgR9               = StixMagicId (VanillaReg WordRep (_ILIT 9))
 311 stgR10              = StixMagicId (VanillaReg WordRep (_ILIT 10))
 312
 313 getNatLabelNCG :: NatM CLabel
 314 getNatLabelNCG
 315   = getUniqueNat `thenNat` \ u ->
 316     returnNat (mkAsmTempLabel u)
 317
 318 getUniqLabelNCG :: UniqSM CLabel
 319 getUniqLabelNCG
 320   = getUniqueUs `thenUs` \ u ->
 321     returnUs (mkAsmTempLabel u)
 322
 323 fixedHS     = StInt (toInteger fixedHdrSize)
 324 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 325 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 326 \end{code}
 327
 328 Stix optimisation passes may wish to find out how many times a
 329 given temporary appears in a tree, so as to be able to decide
 330 whether or not to inline the assignment's RHS at usage site(s).
 331
 332 \begin{code}
 333 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
 334 stixExpr_CountTempUses u t
 335    = let qs = stixStmt_CountTempUses u
 336          qe = stixExpr_CountTempUses u
 337          qr = stixReg_CountTempUses u
 338      in
 339      case t of
 340         StReg      reg            -> qr reg
 341         StIndex    pk t1 t2       -> qe t1 + qe t2
 342         StInd      pk t1          -> qe t1
 343         StMachOp   mop ts         -> sum (map qe ts)
 344         StCall     nm cconv pk ts -> sum (map qe ts)
 345         StInt _          -> 0
 346         StFloat _        -> 0
 347         StDouble _       -> 0
 348         StString _       -> 0
 349         StCLbl _         -> 0
 350
 351 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
 352 stixStmt_CountTempUses u t
 353    = let qe = stixExpr_CountTempUses u
 354          qr = stixReg_CountTempUses u
 355          qv = stixVReg_CountTempUses u
 356      in
 357      case t of
 358         StAssignReg pk reg rhs  -> qr reg + qe rhs
 359         StAssignMem pk addr rhs -> qe addr + qe rhs
 360         StJump     dsts t1      -> qe t1
 361         StCondJump lbl t1       -> qe t1
 362         StData     pk ts        -> sum (map qe ts)
 363         StVoidable expr  -> qe expr
 364         StSegment _      -> 0
 365         StFunBegin _     -> 0
 366         StFunEnd _       -> 0
 367         StFallThrough _  -> 0
 368         StComment _      -> 0
 369         StLabel _        -> 0
 370         StDataString _   -> 0
 371
 372 stixReg_CountTempUses u reg
 373    = case reg of
 374         StixTemp vreg    -> stixVReg_CountTempUses u vreg
 375         StixMagicId mid  -> 0
 376
 377 stixVReg_CountTempUses u (StixVReg uu pr)
 378    = if u == uu then 1 else 0
 379 \end{code}
 380
 381 If we do decide to inline a temporary binding, the following functions
 382 do the biz.
 383
 384 \begin{code}
 385 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
 386 stixStmt_Subst u new_u in_this_tree
 387    = stixStmt_MapUniques f in_this_tree
 388      where
 389         f :: Unique -> Maybe StixExpr
 390         f uu = if uu == u then Just new_u else Nothing
 391
 392
 393 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
 394 stixExpr_MapUniques f t
 395    = let qe = stixExpr_MapUniques f
 396          qs = stixStmt_MapUniques f
 397          qr = stixReg_MapUniques f
 398      in
 399      case t of
 400         StReg reg -> case qr reg of
 401                      Nothing -> StReg reg
 402                      Just xx -> xx
 403         StIndex    pk t1 t2       -> StIndex    pk (qe t1) (qe t2)
 404         StInd      pk t1          -> StInd      pk (qe t1)
 405         StMachOp   mop args       -> StMachOp   mop (map qe args)
 406         StCall     nm cconv pk ts -> StCall     nm cconv pk (map qe ts)
 407         StInt _          -> t
 408         StFloat _        -> t
 409         StDouble _       -> t
 410         StString _       -> t
 411         StCLbl _         -> t
 412
 413 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
 414 stixStmt_MapUniques f t
 415    = let qe = stixExpr_MapUniques f
 416          qs = stixStmt_MapUniques f
 417          qr = stixReg_MapUniques f
 418          qv = stixVReg_MapUniques f
 419      in
 420      case t of
 421         StAssignReg pk reg rhs
 422            -> case qr reg of
 423                  Nothing -> StAssignReg pk reg (qe rhs)
 424                  Just xx -> panic "stixStmt_MapUniques:StAssignReg"
 425         StAssignMem pk addr rhs   -> StAssignMem pk (qe addr) (qe rhs)
 426         StJump     dsts t1        -> StJump     dsts (qe t1)
 427         StCondJump lbl t1         -> StCondJump lbl (qe t1)
 428         StData     pk ts          -> StData     pk (map qe ts)
 429         StVoidable expr           -> StVoidable (qe expr)
 430         StSegment _      -> t
 431         StLabel _        -> t
 432         StFunBegin _     -> t
 433         StFunEnd _       -> t
 434         StFallThrough _  -> t
 435         StComment _      -> t
 436         StDataString _   -> t
 437
 438
 439 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
 440 stixReg_MapUniques f reg
 441    = case reg of
 442         StixMagicId mid -> Nothing
 443         StixTemp vreg   -> stixVReg_MapUniques f vreg
 444
 445 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
 446 stixVReg_MapUniques f (StixVReg uu pr)
 447    = f uu
 448 \end{code}
 449
 450 \begin{code}
 451 -- Lift StStrings out of top-level StDatas, putting them at the end of
 452 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
 453 {- Motivation for this hackery provided by the following bug:
 454    Stix:
 455       (DataSegment)
 456       Bogon.ping_closure :
 457       (Data P_ Addr.A#_static_info)
 458       (Data StgAddr (Str `alalal'))
 459       (Data P_ (0))
 460    results in:
 461       .data
 462               .align 8
 463       .global Bogon_ping_closure
 464       Bogon_ping_closure:
 465               .long   Addr_Azh_static_info
 466               .long   .Ln1a8
 467       .Ln1a8:
 468               .byte   0x61
 469               .byte   0x6C
 470               .byte   0x61
 471               .byte   0x6C
 472               .byte   0x61
 473               .byte   0x6C
 474               .byte   0x00
 475               .long   0
 476    ie, the Str is planted in-line, when what we really meant was to place
 477    a _reference_ to the string there.  liftStrings will lift out all such
 478    strings in top-level data and place them at the end of the block.
 479
 480    This is still a rather half-baked solution -- to do the job entirely right
 481    would mean a complete traversal of all the Stixes, but there's currently no
 482    real need for it, and it would be slow.  Also, potentially there could be
 483    literal types other than strings which need lifting out?
 484 -}
 485
 486 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
 487 liftStrings stmts
 488    = liftStrings_wrk stmts [] []
 489
 490 liftStrings_wrk :: [StixStmt]    -- originals
 491                 -> [StixStmt]    -- (reverse) originals with strings lifted out
 492                 -> [(CLabel, FAST_STRING)]   -- lifted strs, and their new labels
 493                 -> UniqSM [StixStmt]
 494
 495 -- First, examine the original trees and lift out strings in top-level StDatas.
 496 liftStrings_wrk (st:sts) acc_stix acc_strs
 497    = case st of
 498         StData sz datas
 499            -> lift datas acc_strs       `thenUs` \ (datas_done, acc_strs1) ->
 500               liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
 501         other
 502            -> liftStrings_wrk sts (other:acc_stix) acc_strs
 503      where
 504         -- Handle a top-level StData
 505         lift []     acc_strs = returnUs ([], acc_strs)
 506         lift (d:ds) acc_strs
 507            = lift ds acc_strs           `thenUs` \ (ds_done, acc_strs1) ->
 508              case d of
 509                 StString s
 510                    -> getUniqueUs       `thenUs` \ unq ->
 511                       let lbl = mkAsmTempLabel unq in
 512                       returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
 513                 other
 514                    -> returnUs (other:ds_done, acc_strs1)
 515
 516 -- When we've run out of original trees, emit the lifted strings.
 517 liftStrings_wrk [] acc_stix acc_strs
 518    = returnUs (reverse acc_stix ++ concatMap f acc_strs)
 519      where
 520         f (lbl,str) = [StSegment RoDataSegment,
 521                        StLabel lbl,
 522                        StDataString str,
 523                        StSegment TextSegment]
 524 \end{code}
 525
 526 The NCG's monad.
 527
 528 \begin{code}
 529 data NatM_State = NatM_State UniqSupply Int
 530 type NatM result = NatM_State -> (result, NatM_State)
 531
 532 mkNatM_State :: UniqSupply -> Int -> NatM_State
 533 mkNatM_State = NatM_State
 534
 535 uniqOfNatM_State  (NatM_State us delta) = us
 536 deltaOfNatM_State (NatM_State us delta) = delta
 537
 538
 539 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 540 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 541
 542 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 543 thenNat expr cont st
 544   = case expr st of { (result, st') -> cont result st' }
 545
 546 returnNat :: a -> NatM a
 547 returnNat result st = (result, st)
 548
 549 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 550 mapNat f []     = returnNat []
 551 mapNat f (x:xs)
 552   = f x          `thenNat` \ r  ->
 553     mapNat f xs  `thenNat` \ rs ->
 554     returnNat (r:rs)
 555
 556 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 557 mapAndUnzipNat f [] = returnNat ([],[])
 558 mapAndUnzipNat f (x:xs)
 559   = f x                 `thenNat` \ (r1,  r2)  ->
 560     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 561     returnNat (r1:rs1, r2:rs2)
 562
 563 mapAccumLNat :: (acc -> x -> NatM (acc, y))
 564                 -> acc
 565                 -> [x]
 566                 -> NatM (acc, [y])
 567
 568 mapAccumLNat f b []
 569   = returnNat (b, [])
 570 mapAccumLNat f b (x:xs)
 571   = f b x                           `thenNat` \ (b__2, x__2) ->
 572     mapAccumLNat f b__2 xs          `thenNat` \ (b__3, xs__2) ->
 573     returnNat (b__3, x__2:xs__2)
 574
 575
 576 getUniqueNat :: NatM Unique
 577 getUniqueNat (NatM_State us delta)
 578     = case splitUniqSupply us of
 579          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 580
 581 getDeltaNat :: NatM Int
 582 getDeltaNat st@(NatM_State us delta)
 583    = (delta, st)
 584
 585 setDeltaNat :: Int -> NatM ()
 586 setDeltaNat delta (NatM_State us _)
 587    = ((), NatM_State us delta)
 588 \end{code}
 589
 590 Giving up in a not-too-inelegant way.
 591
 592 \begin{code}
 593 ncgPrimopMoan :: String -> SDoc -> a
 594 ncgPrimopMoan msg pp_rep
 595    = unsafePerformIO (
 596         hPutStrLn stderr (
 597         "\n" ++
 598         "You've fallen across an unimplemented case in GHC's native code generation\n" ++
 599         "machinery.  You can work around this for the time being by compiling\n" ++
 600         "this module via the C route, by giving the flag -fvia-C.\n" ++
 601         "The panic below contains information, intended for the GHC implementors,\n" ++
 602         "about the exact place where GHC gave up.  Please send it to us\n" ++
 603         "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
 604         )
 605      )
 606      `seq`
 607      pprPanic msg pp_rep
 608 \end{code}
 609
 610 Information about the target.
 611
 612 \begin{code}
 613
 614 ncg_target_is_32bit :: Bool
 615 ncg_target_is_32bit | wORD_SIZE == 4 = True
 616                     | wORD_SIZE == 8 = False
 617
 618 \end{code}