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