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