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