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 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 Su                   = text "Su"
 274 ppMId SpLim                = text "SpLim"
 275 ppMId Hp                   = text "Hp"
 276 ppMId HpLim                = text "HpLim"
 277 ppMId CurCostCentre        = text "CCC"
 278 ppMId VoidReg              = text "VoidReg"
 279 \end{code}
 280
 281 We hope that every machine supports the idea of data segment and text
 282 segment (or that it has no segments at all, and we can lump these
 283 together).
 284
 285 \begin{code}
 286 data CodeSegment
 287    = DataSegment
 288    | TextSegment
 289    | RoDataSegment
 290      deriving (Eq, Show)
 291
 292 ppCodeSegment = text . show
 293
 294 type StixStmtList = [StixStmt] -> [StixStmt]
 295 \end{code}
 296
 297 Stix Trees for STG registers:
 298 \begin{code}
 299 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 300         :: StixReg
 301
 302 stgBaseReg          = StixMagicId BaseReg
 303 stgNode             = StixMagicId node
 304 stgTagReg           = StixMagicId tagreg
 305 stgSp               = StixMagicId Sp
 306 stgSu               = StixMagicId Su
 307 stgSpLim            = StixMagicId SpLim
 308 stgHp               = StixMagicId Hp
 309 stgHpLim            = StixMagicId HpLim
 310 stgHpAlloc          = StixMagicId HpAlloc
 311 stgCurrentTSO       = StixMagicId CurrentTSO
 312 stgCurrentNursery   = StixMagicId CurrentNursery
 313 stgR9               = StixMagicId (VanillaReg WordRep (_ILIT 9))
 314 stgR10              = StixMagicId (VanillaReg WordRep (_ILIT 10))
 315
 316 getNatLabelNCG :: NatM CLabel
 317 getNatLabelNCG
 318   = getUniqueNat `thenNat` \ u ->
 319     returnNat (mkAsmTempLabel u)
 320
 321 getUniqLabelNCG :: UniqSM CLabel
 322 getUniqLabelNCG
 323   = getUniqueUs `thenUs` \ u ->
 324     returnUs (mkAsmTempLabel u)
 325
 326 fixedHS     = StInt (toInteger fixedHdrSize)
 327 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 328 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 329 \end{code}
 330
 331 Stix optimisation passes may wish to find out how many times a
 332 given temporary appears in a tree, so as to be able to decide
 333 whether or not to inline the assignment's RHS at usage site(s).
 334
 335 \begin{code}
 336 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
 337 stixExpr_CountTempUses u t
 338    = let qs = stixStmt_CountTempUses u
 339          qe = stixExpr_CountTempUses u
 340          qr = stixReg_CountTempUses u
 341      in
 342      case t of
 343         StReg      reg            -> qr reg
 344         StIndex    pk t1 t2       -> qe t1 + qe t2
 345         StInd      pk t1          -> qe t1
 346         StMachOp   mop ts         -> sum (map qe ts)
 347         StCall     (Left nm) cconv pk ts -> sum (map qe ts)
 348         StCall     (Right f) cconv pk ts -> sum (map qe ts) + qe f
 349         StInt _          -> 0
 350         StFloat _        -> 0
 351         StDouble _       -> 0
 352         StString _       -> 0
 353         StCLbl _         -> 0
 354
 355 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
 356 stixStmt_CountTempUses u t
 357    = let qe = stixExpr_CountTempUses u
 358          qr = stixReg_CountTempUses u
 359          qv = stixVReg_CountTempUses u
 360      in
 361      case t of
 362         StAssignReg pk reg rhs  -> qr reg + qe rhs
 363         StAssignMem pk addr rhs -> qe addr + qe rhs
 364         StJump     dsts t1      -> qe t1
 365         StCondJump lbl t1       -> qe t1
 366         StData     pk ts        -> sum (map qe ts)
 367         StVoidable expr  -> qe expr
 368         StSegment _      -> 0
 369         StFunBegin _     -> 0
 370         StFunEnd _       -> 0
 371         StFallThrough _  -> 0
 372         StComment _      -> 0
 373         StLabel _        -> 0
 374         StDataString _   -> 0
 375
 376 stixReg_CountTempUses u reg
 377    = case reg of
 378         StixTemp vreg    -> stixVReg_CountTempUses u vreg
 379         StixMagicId mid  -> 0
 380
 381 stixVReg_CountTempUses u (StixVReg uu pr)
 382    = if u == uu then 1 else 0
 383 \end{code}
 384
 385 If we do decide to inline a temporary binding, the following functions
 386 do the biz.
 387
 388 \begin{code}
 389 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
 390 stixStmt_Subst u new_u in_this_tree
 391    = stixStmt_MapUniques f in_this_tree
 392      where
 393         f :: Unique -> Maybe StixExpr
 394         f uu = if uu == u then Just new_u else Nothing
 395
 396
 397 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
 398 stixExpr_MapUniques f t
 399    = let qe = stixExpr_MapUniques f
 400          qs = stixStmt_MapUniques f
 401          qr = stixReg_MapUniques f
 402      in
 403      case t of
 404         StReg reg -> case qr reg of
 405                      Nothing -> StReg reg
 406                      Just xx -> xx
 407         StIndex    pk t1 t2       -> StIndex    pk (qe t1) (qe t2)
 408         StInd      pk t1          -> StInd      pk (qe t1)
 409         StMachOp   mop args       -> StMachOp   mop (map qe args)
 410         StCall     (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
 411         StCall     (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
 412         StInt _          -> t
 413         StFloat _        -> t
 414         StDouble _       -> t
 415         StString _       -> t
 416         StCLbl _         -> t
 417
 418 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
 419 stixStmt_MapUniques f t
 420    = let qe = stixExpr_MapUniques f
 421          qs = stixStmt_MapUniques f
 422          qr = stixReg_MapUniques f
 423          qv = stixVReg_MapUniques f
 424      in
 425      case t of
 426         StAssignReg pk reg rhs
 427            -> case qr reg of
 428                  Nothing -> StAssignReg pk reg (qe rhs)
 429                  Just xx -> panic "stixStmt_MapUniques:StAssignReg"
 430         StAssignMem pk addr rhs   -> StAssignMem pk (qe addr) (qe rhs)
 431         StJump     dsts t1        -> StJump     dsts (qe t1)
 432         StCondJump lbl t1         -> StCondJump lbl (qe t1)
 433         StData     pk ts          -> StData     pk (map qe ts)
 434         StVoidable expr           -> StVoidable (qe expr)
 435         StSegment _      -> t
 436         StLabel _        -> t
 437         StFunBegin _     -> t
 438         StFunEnd _       -> t
 439         StFallThrough _  -> t
 440         StComment _      -> t
 441         StDataString _   -> t
 442
 443
 444 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
 445 stixReg_MapUniques f reg
 446    = case reg of
 447         StixMagicId mid -> Nothing
 448         StixTemp vreg   -> stixVReg_MapUniques f vreg
 449
 450 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
 451 stixVReg_MapUniques f (StixVReg uu pr)
 452    = f uu
 453 \end{code}
 454
 455 \begin{code}
 456 -- Lift StStrings out of top-level StDatas, putting them at the end of
 457 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
 458 {- Motivation for this hackery provided by the following bug:
 459    Stix:
 460       (DataSegment)
 461       Bogon.ping_closure :
 462       (Data P_ Addr.A#_static_info)
 463       (Data StgAddr (Str `alalal'))
 464       (Data P_ (0))
 465    results in:
 466       .data
 467               .align 8
 468       .global Bogon_ping_closure
 469       Bogon_ping_closure:
 470               .long   Addr_Azh_static_info
 471               .long   .Ln1a8
 472       .Ln1a8:
 473               .byte   0x61
 474               .byte   0x6C
 475               .byte   0x61
 476               .byte   0x6C
 477               .byte   0x61
 478               .byte   0x6C
 479               .byte   0x00
 480               .long   0
 481    ie, the Str is planted in-line, when what we really meant was to place
 482    a _reference_ to the string there.  liftStrings will lift out all such
 483    strings in top-level data and place them at the end of the block.
 484
 485    This is still a rather half-baked solution -- to do the job entirely right
 486    would mean a complete traversal of all the Stixes, but there's currently no
 487    real need for it, and it would be slow.  Also, potentially there could be
 488    literal types other than strings which need lifting out?
 489 -}
 490
 491 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
 492 liftStrings stmts
 493    = liftStrings_wrk stmts [] []
 494
 495 liftStrings_wrk :: [StixStmt]    -- originals
 496                 -> [StixStmt]    -- (reverse) originals with strings lifted out
 497                 -> [(CLabel, FastString)]   -- lifted strs, and their new labels
 498                 -> UniqSM [StixStmt]
 499
 500 -- First, examine the original trees and lift out strings in top-level StDatas.
 501 liftStrings_wrk (st:sts) acc_stix acc_strs
 502    = case st of
 503         StData sz datas
 504            -> lift datas acc_strs       `thenUs` \ (datas_done, acc_strs1) ->
 505               liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
 506         other
 507            -> liftStrings_wrk sts (other:acc_stix) acc_strs
 508      where
 509         -- Handle a top-level StData
 510         lift []     acc_strs = returnUs ([], acc_strs)
 511         lift (d:ds) acc_strs
 512            = lift ds acc_strs           `thenUs` \ (ds_done, acc_strs1) ->
 513              case d of
 514                 StString s
 515                    -> getUniqueUs       `thenUs` \ unq ->
 516                       let lbl = mkAsmTempLabel unq in
 517                       returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
 518                 other
 519                    -> returnUs (other:ds_done, acc_strs1)
 520
 521 -- When we've run out of original trees, emit the lifted strings.
 522 liftStrings_wrk [] acc_stix acc_strs
 523    = returnUs (reverse acc_stix ++ concatMap f acc_strs)
 524      where
 525         f (lbl,str) = [StSegment RoDataSegment,
 526                        StLabel lbl,
 527                        StDataString str,
 528                        StSegment TextSegment]
 529 \end{code}
 530
 531 The NCG's monad.
 532
 533 \begin{code}
 534 data NatM_State = NatM_State UniqSupply Int
 535 type NatM result = NatM_State -> (result, NatM_State)
 536
 537 mkNatM_State :: UniqSupply -> Int -> NatM_State
 538 mkNatM_State = NatM_State
 539
 540 uniqOfNatM_State  (NatM_State us delta) = us
 541 deltaOfNatM_State (NatM_State us delta) = delta
 542
 543
 544 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 545 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 546
 547 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 548 thenNat expr cont st
 549   = case expr st of { (result, st') -> cont result st' }
 550
 551 returnNat :: a -> NatM a
 552 returnNat result st = (result, st)
 553
 554 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 555 mapNat f []     = returnNat []
 556 mapNat f (x:xs)
 557   = f x          `thenNat` \ r  ->
 558     mapNat f xs  `thenNat` \ rs ->
 559     returnNat (r:rs)
 560
 561 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 562 mapAndUnzipNat f [] = returnNat ([],[])
 563 mapAndUnzipNat f (x:xs)
 564   = f x                 `thenNat` \ (r1,  r2)  ->
 565     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 566     returnNat (r1:rs1, r2:rs2)
 567
 568 mapAccumLNat :: (acc -> x -> NatM (acc, y))
 569                 -> acc
 570                 -> [x]
 571                 -> NatM (acc, [y])
 572
 573 mapAccumLNat f b []
 574   = returnNat (b, [])
 575 mapAccumLNat f b (x:xs)
 576   = f b x                           `thenNat` \ (b__2, x__2) ->
 577     mapAccumLNat f b__2 xs          `thenNat` \ (b__3, xs__2) ->
 578     returnNat (b__3, x__2:xs__2)
 579
 580
 581 getUniqueNat :: NatM Unique
 582 getUniqueNat (NatM_State us delta)
 583     = case splitUniqSupply us of
 584          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 585
 586 getDeltaNat :: NatM Int
 587 getDeltaNat st@(NatM_State us delta)
 588    = (delta, st)
 589
 590 setDeltaNat :: Int -> NatM ()
 591 setDeltaNat delta (NatM_State us _)
 592    = ((), NatM_State us delta)
 593 \end{code}
 594
 595 Giving up in a not-too-inelegant way.
 596
 597 \begin{code}
 598 ncgPrimopMoan :: String -> SDoc -> a
 599 ncgPrimopMoan msg pp_rep
 600    = unsafePerformIO (
 601         hPutStrLn stderr (
 602         "\n" ++
 603         "You've fallen across an unimplemented case in GHC's native code generation\n" ++
 604         "machinery.  You can work around this for the time being by compiling\n" ++
 605         "this module via the C route, by giving the flag -fvia-C.\n" ++
 606         "The panic below contains information, intended for the GHC implementors,\n" ++
 607         "about the exact place where GHC gave up.  Please send it to us\n" ++
 608         "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
 609         )
 610      )
 611      `seq`
 612      pprPanic msg pp_rep
 613 \end{code}
 614
 615 Information about the target.
 616
 617 \begin{code}
 618
 619 ncg_target_is_32bit :: Bool
 620 ncg_target_is_32bit | wORD_SIZE == 4 = True
 621                     | wORD_SIZE == 8 = False
 622
 623 \end{code}