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 (Either FAST_STRING StixExpr) -- Left: static, Right: dynamic
 154            CCallConv PrimRep [StixExpr]
 155
 156
 157 -- What's the PrimRep of the value denoted by this StixExpr?
 158 repOfStixExpr :: StixExpr -> PrimRep
 159 repOfStixExpr (StInt _)       = IntRep
 160 repOfStixExpr (StFloat _)     = FloatRep
 161 repOfStixExpr (StDouble _)    = DoubleRep
 162 repOfStixExpr (StString _)    = PtrRep
 163 repOfStixExpr (StCLbl _)      = PtrRep
 164 repOfStixExpr (StReg reg)     = repOfStixReg reg
 165 repOfStixExpr (StIndex _ _ _) = PtrRep
 166 repOfStixExpr (StInd rep _)   = rep
 167 repOfStixExpr (StCall target conv retrep args) = retrep
 168 repOfStixExpr (StMachOp mop args)
 169    = case resultRepsOfMachOp mop of
 170         Just rep -> rep
 171         Nothing  -> pprPanic "repOfStixExpr:StMachOp" (pprMachOp mop)
 172
 173
 174 -- used by insnFuture in RegAllocInfo.lhs
 175 data DestInfo
 176    = NoDestInfo             -- no supplied dests; infer from context
 177    | DestInfo [CLabel]      -- precisely these dests and no others
 178
 179 hasDestInfo NoDestInfo   = False
 180 hasDestInfo (DestInfo _) = True
 181
 182 pprDests :: DestInfo -> SDoc
 183 pprDests NoDestInfo      = text "NoDestInfo"
 184 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
 185
 186
 187 pprStixStmts :: [StixStmt] -> SDoc
 188 pprStixStmts ts
 189   = vcat [
 190        vcat (map pprStixStmt ts),
 191        char ' ',
 192        char ' '
 193     ]
 194
 195
 196 pprStixExpr :: StixExpr -> SDoc
 197 pprStixExpr t
 198    = case t of
 199        StCLbl lbl       -> pprCLabel lbl
 200        StInt i          -> (if i < 0 then parens else id) (integer i)
 201        StFloat rat      -> parens (text "Float" <+> rational rat)
 202        StDouble rat     -> parens (text "Double" <+> rational rat)
 203        StString str     -> parens (text "Str `" <> ptext str <> char '\'')
 204        StIndex k b o    -> parens (pprStixExpr b <+> char '+' <>
 205                                    ppr k <+> pprStixExpr o)
 206        StInd k t        -> ppr k <> char '[' <> pprStixExpr t <> char ']'
 207        StReg reg        -> pprStixReg reg
 208        StMachOp op args -> pprMachOp op
 209                            <> parens (hsep (punctuate comma (map pprStixExpr args)))
 210        StCall fn cc k args
 211                         -> parens (text "Call" <+> targ <+>
 212                                    ppr cc <+> ppr k <+>
 213                                    hsep (map pprStixExpr args))
 214                            where
 215                               targ = case fn of
 216                                         Left  t_static -> ptext t_static
 217                                         Right t_dyn    -> parens (pprStixExpr t_dyn)
 218
 219 pprStixStmt :: StixStmt -> SDoc
 220 pprStixStmt t
 221    = case t of
 222        StSegment cseg   -> parens (ppCodeSegment cseg)
 223        StComment str    -> parens (text "Comment" <+> ptext str)
 224        StAssignReg pr reg rhs
 225                         -> pprStixReg reg <> text "  :=" <> ppr pr
 226                                           <> text "  " <> pprStixExpr rhs
 227        StAssignMem pr addr rhs
 228                         -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
 229                                   <> text "  :=" <> ppr pr
 230                                   <> text "  " <> pprStixExpr rhs
 231        StLabel ll       -> pprCLabel ll <+> char ':'
 232        StFunBegin ll    -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
 233        StFunEnd ll      -> parens (text "FunEnd" <+> pprCLabel ll)
 234        StJump dsts t    -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
 235        StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
 236        StCondJump l t   -> parens (text "JumpC" <+> pprCLabel l
 237                                                 <+> pprStixExpr t)
 238        StData k ds      -> parens (text "Data" <+> ppr k <+>
 239                                    hsep (map pprStixExpr ds))
 240        StDataString str -> parens (text "DataString" <+> ppr str)
 241        StVoidable expr  -> text "(void)" <+> pprStixExpr expr
 242 \end{code}
 243
 244 Stix registers can have two forms.  They {\em may} or {\em may not}
 245 map to real, machine-level registers.
 246
 247 \begin{code}
 248 data StixReg
 249   = StixMagicId MagicId -- Regs which are part of the abstract machine model
 250
 251   | StixTemp StixVReg   -- "Regs" which model local variables (CTemps) in
 252                         -- the abstract C.
 253
 254 pprStixReg (StixMagicId mid)  = ppMId mid
 255 pprStixReg (StixTemp temp)    = pprStixVReg temp
 256
 257 repOfStixReg (StixTemp (StixVReg u pr)) = pr
 258 repOfStixReg (StixMagicId mid)          = magicIdPrimRep mid
 259
 260 data StixVReg
 261    = StixVReg Unique PrimRep
 262
 263 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
 264
 265
 266
 267 ppMId BaseReg              = text "BaseReg"
 268 ppMId (VanillaReg kind n)  = hcat [ppr kind, text "IntReg(",
 269                                    int (iBox n), char ')']
 270 ppMId (FloatReg n)         = hcat [text "FltReg(", int (iBox n), char ')']
 271 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (iBox n), char ')']
 272 ppMId (LongReg kind n)     = hcat [ppr kind, text "LongReg(",
 273                                    int (iBox n), char ')']
 274 ppMId Sp                   = text "Sp"
 275 ppMId Su                   = text "Su"
 276 ppMId SpLim                = text "SpLim"
 277 ppMId Hp                   = text "Hp"
 278 ppMId HpLim                = text "HpLim"
 279 ppMId CurCostCentre        = text "CCC"
 280 ppMId VoidReg              = text "VoidReg"
 281 \end{code}
 282
 283 We hope that every machine supports the idea of data segment and text
 284 segment (or that it has no segments at all, and we can lump these
 285 together).
 286
 287 \begin{code}
 288 data CodeSegment
 289    = DataSegment
 290    | TextSegment
 291    | RoDataSegment
 292      deriving (Eq, Show)
 293
 294 ppCodeSegment = text . show
 295
 296 type StixStmtList = [StixStmt] -> [StixStmt]
 297 \end{code}
 298
 299 Stix Trees for STG registers:
 300 \begin{code}
 301 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 302         :: StixReg
 303
 304 stgBaseReg          = StixMagicId BaseReg
 305 stgNode             = StixMagicId node
 306 stgTagReg           = StixMagicId tagreg
 307 stgSp               = StixMagicId Sp
 308 stgSu               = StixMagicId Su
 309 stgSpLim            = StixMagicId SpLim
 310 stgHp               = StixMagicId Hp
 311 stgHpLim            = StixMagicId HpLim
 312 stgHpAlloc          = StixMagicId HpAlloc
 313 stgCurrentTSO       = StixMagicId CurrentTSO
 314 stgCurrentNursery   = StixMagicId CurrentNursery
 315 stgR9               = StixMagicId (VanillaReg WordRep (_ILIT 9))
 316 stgR10              = StixMagicId (VanillaReg WordRep (_ILIT 10))
 317
 318 getNatLabelNCG :: NatM CLabel
 319 getNatLabelNCG
 320   = getUniqueNat `thenNat` \ u ->
 321     returnNat (mkAsmTempLabel u)
 322
 323 getUniqLabelNCG :: UniqSM CLabel
 324 getUniqLabelNCG
 325   = getUniqueUs `thenUs` \ u ->
 326     returnUs (mkAsmTempLabel u)
 327
 328 fixedHS     = StInt (toInteger fixedHdrSize)
 329 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 330 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 331 \end{code}
 332
 333 Stix optimisation passes may wish to find out how many times a
 334 given temporary appears in a tree, so as to be able to decide
 335 whether or not to inline the assignment's RHS at usage site(s).
 336
 337 \begin{code}
 338 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
 339 stixExpr_CountTempUses u t
 340    = let qs = stixStmt_CountTempUses u
 341          qe = stixExpr_CountTempUses u
 342          qr = stixReg_CountTempUses u
 343      in
 344      case t of
 345         StReg      reg            -> qr reg
 346         StIndex    pk t1 t2       -> qe t1 + qe t2
 347         StInd      pk t1          -> qe t1
 348         StMachOp   mop ts         -> sum (map qe ts)
 349         StCall     (Left nm) cconv pk ts -> sum (map qe ts)
 350         StCall     (Right f) cconv pk ts -> sum (map qe ts) + qe f
 351         StInt _          -> 0
 352         StFloat _        -> 0
 353         StDouble _       -> 0
 354         StString _       -> 0
 355         StCLbl _         -> 0
 356
 357 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
 358 stixStmt_CountTempUses u t
 359    = let qe = stixExpr_CountTempUses u
 360          qr = stixReg_CountTempUses u
 361          qv = stixVReg_CountTempUses u
 362      in
 363      case t of
 364         StAssignReg pk reg rhs  -> qr reg + qe rhs
 365         StAssignMem pk addr rhs -> qe addr + qe rhs
 366         StJump     dsts t1      -> qe t1
 367         StCondJump lbl t1       -> qe t1
 368         StData     pk ts        -> sum (map qe ts)
 369         StVoidable expr  -> qe expr
 370         StSegment _      -> 0
 371         StFunBegin _     -> 0
 372         StFunEnd _       -> 0
 373         StFallThrough _  -> 0
 374         StComment _      -> 0
 375         StLabel _        -> 0
 376         StDataString _   -> 0
 377
 378 stixReg_CountTempUses u reg
 379    = case reg of
 380         StixTemp vreg    -> stixVReg_CountTempUses u vreg
 381         StixMagicId mid  -> 0
 382
 383 stixVReg_CountTempUses u (StixVReg uu pr)
 384    = if u == uu then 1 else 0
 385 \end{code}
 386
 387 If we do decide to inline a temporary binding, the following functions
 388 do the biz.
 389
 390 \begin{code}
 391 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
 392 stixStmt_Subst u new_u in_this_tree
 393    = stixStmt_MapUniques f in_this_tree
 394      where
 395         f :: Unique -> Maybe StixExpr
 396         f uu = if uu == u then Just new_u else Nothing
 397
 398
 399 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
 400 stixExpr_MapUniques f t
 401    = let qe = stixExpr_MapUniques f
 402          qs = stixStmt_MapUniques f
 403          qr = stixReg_MapUniques f
 404      in
 405      case t of
 406         StReg reg -> case qr reg of
 407                      Nothing -> StReg reg
 408                      Just xx -> xx
 409         StIndex    pk t1 t2       -> StIndex    pk (qe t1) (qe t2)
 410         StInd      pk t1          -> StInd      pk (qe t1)
 411         StMachOp   mop args       -> StMachOp   mop (map qe args)
 412         StCall     (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
 413         StCall     (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
 414         StInt _          -> t
 415         StFloat _        -> t
 416         StDouble _       -> t
 417         StString _       -> t
 418         StCLbl _         -> t
 419
 420 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
 421 stixStmt_MapUniques f t
 422    = let qe = stixExpr_MapUniques f
 423          qs = stixStmt_MapUniques f
 424          qr = stixReg_MapUniques f
 425          qv = stixVReg_MapUniques f
 426      in
 427      case t of
 428         StAssignReg pk reg rhs
 429            -> case qr reg of
 430                  Nothing -> StAssignReg pk reg (qe rhs)
 431                  Just xx -> panic "stixStmt_MapUniques:StAssignReg"
 432         StAssignMem pk addr rhs   -> StAssignMem pk (qe addr) (qe rhs)
 433         StJump     dsts t1        -> StJump     dsts (qe t1)
 434         StCondJump lbl t1         -> StCondJump lbl (qe t1)
 435         StData     pk ts          -> StData     pk (map qe ts)
 436         StVoidable expr           -> StVoidable (qe expr)
 437         StSegment _      -> t
 438         StLabel _        -> t
 439         StFunBegin _     -> t
 440         StFunEnd _       -> t
 441         StFallThrough _  -> t
 442         StComment _      -> t
 443         StDataString _   -> t
 444
 445
 446 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
 447 stixReg_MapUniques f reg
 448    = case reg of
 449         StixMagicId mid -> Nothing
 450         StixTemp vreg   -> stixVReg_MapUniques f vreg
 451
 452 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
 453 stixVReg_MapUniques f (StixVReg uu pr)
 454    = f uu
 455 \end{code}
 456
 457 \begin{code}
 458 -- Lift StStrings out of top-level StDatas, putting them at the end of
 459 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
 460 {- Motivation for this hackery provided by the following bug:
 461    Stix:
 462       (DataSegment)
 463       Bogon.ping_closure :
 464       (Data P_ Addr.A#_static_info)
 465       (Data StgAddr (Str `alalal'))
 466       (Data P_ (0))
 467    results in:
 468       .data
 469               .align 8
 470       .global Bogon_ping_closure
 471       Bogon_ping_closure:
 472               .long   Addr_Azh_static_info
 473               .long   .Ln1a8
 474       .Ln1a8:
 475               .byte   0x61
 476               .byte   0x6C
 477               .byte   0x61
 478               .byte   0x6C
 479               .byte   0x61
 480               .byte   0x6C
 481               .byte   0x00
 482               .long   0
 483    ie, the Str is planted in-line, when what we really meant was to place
 484    a _reference_ to the string there.  liftStrings will lift out all such
 485    strings in top-level data and place them at the end of the block.
 486
 487    This is still a rather half-baked solution -- to do the job entirely right
 488    would mean a complete traversal of all the Stixes, but there's currently no
 489    real need for it, and it would be slow.  Also, potentially there could be
 490    literal types other than strings which need lifting out?
 491 -}
 492
 493 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
 494 liftStrings stmts
 495    = liftStrings_wrk stmts [] []
 496
 497 liftStrings_wrk :: [StixStmt]    -- originals
 498                 -> [StixStmt]    -- (reverse) originals with strings lifted out
 499                 -> [(CLabel, FAST_STRING)]   -- lifted strs, and their new labels
 500                 -> UniqSM [StixStmt]
 501
 502 -- First, examine the original trees and lift out strings in top-level StDatas.
 503 liftStrings_wrk (st:sts) acc_stix acc_strs
 504    = case st of
 505         StData sz datas
 506            -> lift datas acc_strs       `thenUs` \ (datas_done, acc_strs1) ->
 507               liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
 508         other
 509            -> liftStrings_wrk sts (other:acc_stix) acc_strs
 510      where
 511         -- Handle a top-level StData
 512         lift []     acc_strs = returnUs ([], acc_strs)
 513         lift (d:ds) acc_strs
 514            = lift ds acc_strs           `thenUs` \ (ds_done, acc_strs1) ->
 515              case d of
 516                 StString s
 517                    -> getUniqueUs       `thenUs` \ unq ->
 518                       let lbl = mkAsmTempLabel unq in
 519                       returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
 520                 other
 521                    -> returnUs (other:ds_done, acc_strs1)
 522
 523 -- When we've run out of original trees, emit the lifted strings.
 524 liftStrings_wrk [] acc_stix acc_strs
 525    = returnUs (reverse acc_stix ++ concatMap f acc_strs)
 526      where
 527         f (lbl,str) = [StSegment RoDataSegment,
 528                        StLabel lbl,
 529                        StDataString str,
 530                        StSegment TextSegment]
 531 \end{code}
 532
 533 The NCG's monad.
 534
 535 \begin{code}
 536 data NatM_State = NatM_State UniqSupply Int
 537 type NatM result = NatM_State -> (result, NatM_State)
 538
 539 mkNatM_State :: UniqSupply -> Int -> NatM_State
 540 mkNatM_State = NatM_State
 541
 542 uniqOfNatM_State  (NatM_State us delta) = us
 543 deltaOfNatM_State (NatM_State us delta) = delta
 544
 545
 546 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 547 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 548
 549 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 550 thenNat expr cont st
 551   = case expr st of { (result, st') -> cont result st' }
 552
 553 returnNat :: a -> NatM a
 554 returnNat result st = (result, st)
 555
 556 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 557 mapNat f []     = returnNat []
 558 mapNat f (x:xs)
 559   = f x          `thenNat` \ r  ->
 560     mapNat f xs  `thenNat` \ rs ->
 561     returnNat (r:rs)
 562
 563 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 564 mapAndUnzipNat f [] = returnNat ([],[])
 565 mapAndUnzipNat f (x:xs)
 566   = f x                 `thenNat` \ (r1,  r2)  ->
 567     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 568     returnNat (r1:rs1, r2:rs2)
 569
 570 mapAccumLNat :: (acc -> x -> NatM (acc, y))
 571                 -> acc
 572                 -> [x]
 573                 -> NatM (acc, [y])
 574
 575 mapAccumLNat f b []
 576   = returnNat (b, [])
 577 mapAccumLNat f b (x:xs)
 578   = f b x                           `thenNat` \ (b__2, x__2) ->
 579     mapAccumLNat f b__2 xs          `thenNat` \ (b__3, xs__2) ->
 580     returnNat (b__3, x__2:xs__2)
 581
 582
 583 getUniqueNat :: NatM Unique
 584 getUniqueNat (NatM_State us delta)
 585     = case splitUniqSupply us of
 586          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 587
 588 getDeltaNat :: NatM Int
 589 getDeltaNat st@(NatM_State us delta)
 590    = (delta, st)
 591
 592 setDeltaNat :: Int -> NatM ()
 593 setDeltaNat delta (NatM_State us _)
 594    = ((), NatM_State us delta)
 595 \end{code}
 596
 597 Giving up in a not-too-inelegant way.
 598
 599 \begin{code}
 600 ncgPrimopMoan :: String -> SDoc -> a
 601 ncgPrimopMoan msg pp_rep
 602    = unsafePerformIO (
 603         hPutStrLn stderr (
 604         "\n" ++
 605         "You've fallen across an unimplemented case in GHC's native code generation\n" ++
 606         "machinery.  You can work around this for the time being by compiling\n" ++
 607         "this module via the C route, by giving the flag -fvia-C.\n" ++
 608         "The panic below contains information, intended for the GHC implementors,\n" ++
 609         "about the exact place where GHC gave up.  Please send it to us\n" ++
 610         "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
 611         )
 612      )
 613      `seq`
 614      pprPanic msg pp_rep
 615 \end{code}
 616
 617 Information about the target.
 618
 619 \begin{code}
 620
 621 ncg_target_is_32bit :: Bool
 622 ncg_target_is_32bit | wORD_SIZE == 4 = True
 623                     | wORD_SIZE == 8 = False
 624
 625 \end{code}