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