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