\begin{code}
module Stix (
- CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
- pprStixTrees, pprStixTree, ppStixReg,
- stixCountTempUses, stixSubst,
+ CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..),
+ StixStmt(..), mkStAssign, StixStmtList,
+ pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
+ stixStmt_CountTempUses, stixStmt_Subst,
+ liftStrings, repOfStixExpr,
DestInfo(..), hasDestInfo,
- stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
- stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
+ stgBaseReg, stgNode, stgSp, stgSpLim,
+ stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
stgCurrentTSO, stgCurrentNursery,
fixedHS, arrWordsHS, arrPtrsHS,
mapNat, mapAndUnzipNat, mapAccumLNat,
getUniqueNat, getDeltaNat, setDeltaNat,
NatM_State, mkNatM_State,
- uniqOfNatM_State, deltaOfNatM_State,
+ uniqOfNatM_State, deltaOfNatM_State, importsOfNatM_State,
+ addImportNat,
getUniqLabelNCG, getNatLabelNCG,
- ncgPrimopMoan
+ ncgPrimopMoan,
+
+ -- Information about the target arch
+ ncg_target_is_32bit
) where
#include "HsVersions.h"
-import Ratio ( Rational )
-import IOExts ( unsafePerformIO )
-import IO ( hPutStrLn, stderr )
-
import AbsCSyn ( node, tagreg, MagicId(..) )
+import AbsCUtils ( magicIdPrimRep )
import ForeignCall ( CCallConv )
import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
import PrimRep ( PrimRep(..) )
-import PrimOp ( PrimOp )
+import MachOp ( MachOp(..), pprMachOp, resultRepOfMachOp )
import Unique ( Unique )
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
+import Constants ( wORD_SIZE )
import Outputable
import FastTypes
-\end{code}
-
-Here is the tag at the nodes of our @StixTree@. Notice its
-relationship with @PrimOp@ in prelude/PrimOp.
-
-\begin{code}
-data StixTree
- = -- Segment (text or data)
-
- StSegment CodeSegment
-
- -- We can tag the leaves with constants/immediates.
+import FastString
- | StInt Integer -- ** add Kind at some point
- | StFloat Rational
- | StDouble Rational
- | StString FAST_STRING
- | StCLbl CLabel -- labels that we might index into
+import UNSAFE_IO ( unsafePerformIO )
- -- Abstract registers of various kinds
+import Ratio ( Rational )
+import IO ( hPutStrLn, stderr )
+\end{code}
- | StReg StixReg
+Two types, StixStmt and StixValue, define Stix.
- -- A typed offset from a base location
+\begin{code}
- | StIndex PrimRep StixTree StixTree -- kind, base, offset
+-- Non-value trees; ones executed for their side-effect.
+data StixStmt
- -- An indirection from an address to its contents.
+ = -- Directive for the assembler to change segment
+ StSegment CodeSegment
- | StInd PrimRep StixTree
+ -- Assembly-language comments
+ | StComment FastString
- -- Assignment is typed to determine size and register placement
+ -- Assignments are typed to determine size and register placement.
+ -- Assign a value to a StixReg
+ | StAssignReg PrimRep StixReg StixExpr
- | StAssign PrimRep StixTree StixTree -- dst, src
+ -- Assign a value to memory. First tree indicates the address to be
+ -- assigned to, so there is an implicit dereference here.
+ | StAssignMem PrimRep StixExpr StixExpr -- dst, src
-- A simple assembly label that we might jump to.
-
| StLabel CLabel
-- A function header and footer
-
| StFunBegin CLabel
| StFunEnd CLabel
-- the exact targets to be attached, so that the allocator can
-- easily construct the exact flow edges leaving this insn.
-- Dynamic targets are allowed.
-
- | StJump DestInfo StixTree
+ | StJump DestInfo StixExpr
-- A fall-through, from slow to fast
-
| StFallThrough CLabel
-- A conditional jump. This instruction can be non-terminal :-)
-- Only static, local, forward labels are allowed
-
- | StCondJump CLabel StixTree
+ | StCondJump CLabel StixExpr
-- Raw data (as in an info table).
+ | StData PrimRep [StixExpr]
+ -- String which has been lifted to the top level (sigh).
+ | StDataString FastString
+
+ -- A value computed only for its side effects; result is discarded
+ -- (A handy trapdoor to allow CCalls with no results to appear as
+ -- statements).
+ | StVoidable StixExpr
+
+
+-- Helper fn to make Stix assignment statements where the
+-- lvalue masquerades as a StixExpr. A kludge that should
+-- be done away with.
+mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
+mkStAssign rep (StReg reg) rhs
+ = StAssignReg rep reg rhs
+mkStAssign rep (StInd rep' addr) rhs
+ | rep `isCloseEnoughTo` rep'
+ = StAssignMem rep addr rhs
+ | otherwise
+ = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
+ --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
+ StAssignMem rep addr rhs
+ --)
+ where
+ isCloseEnoughTo r1 r2
+ = r1 == r2 || (wordIsh r1 && wordIsh r2)
+ wordIsh rep
+ = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ]
+ -- determined by looking at PrimRep.showPrimRep
+
+-- Stix trees which denote a value.
+data StixExpr
+ = -- Literals
+ StInt Integer -- ** add Kind at some point
+ | StFloat Rational
+ | StDouble Rational
+ | StString FastString
+ | StCLbl CLabel -- labels that we might index into
- | StData PrimRep [StixTree]
-
- -- Primitive Operations
-
- | StPrim PrimOp [StixTree]
+ -- Abstract registers of various kinds
+ | StReg StixReg
- -- Calls to C functions
+ -- A typed offset from a base location
+ | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
- | StCall FAST_STRING CCallConv PrimRep [StixTree]
+ -- An indirection from an address to its contents.
+ | StInd PrimRep StixExpr
- -- A volatile memory scratch array, which is allocated
- -- relative to the stack pointer. It is an array of
- -- ptr/word/int sized things. Do not expect to be preserved
- -- beyond basic blocks or over a ccall. Current max size
- -- is 6, used in StixInteger.
+ -- Primitive Operations
+ | StMachOp MachOp [StixExpr]
- | StScratchWord Int
+ -- Calls to C functions
+ | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic
+ CCallConv PrimRep [StixExpr]
- -- Assembly-language comments
- | StComment FAST_STRING
+-- What's the PrimRep of the value denoted by this StixExpr?
+repOfStixExpr :: StixExpr -> PrimRep
+repOfStixExpr (StInt _) = IntRep
+repOfStixExpr (StFloat _) = FloatRep
+repOfStixExpr (StDouble _) = DoubleRep
+repOfStixExpr (StString _) = PtrRep
+repOfStixExpr (StCLbl _) = PtrRep
+repOfStixExpr (StReg reg) = repOfStixReg reg
+repOfStixExpr (StIndex _ _ _) = PtrRep
+repOfStixExpr (StInd rep _) = rep
+repOfStixExpr (StCall target conv retrep args) = retrep
+repOfStixExpr (StMachOp mop args) = resultRepOfMachOp mop
-- used by insnFuture in RegAllocInfo.lhs
pprDests :: DestInfo -> SDoc
pprDests NoDestInfo = text "NoDestInfo"
-pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
+pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
-pprStixTrees :: [StixTree] -> SDoc
-pprStixTrees ts
+pprStixStmts :: [StixStmt] -> SDoc
+pprStixStmts ts
= vcat [
- vcat (map pprStixTree ts),
+ vcat (map pprStixStmt ts),
char ' ',
char ' '
]
-paren t = char '(' <> t <> char ')'
-brack t = char '[' <> t <> char ']'
-pprStixTree :: StixTree -> SDoc
-pprStixTree t
+pprStixExpr :: StixExpr -> SDoc
+pprStixExpr t
= case t of
- StSegment cseg -> paren (ppCodeSegment cseg)
- StInt i -> paren (integer i)
- StFloat rat -> paren (text "Float" <+> rational rat)
- StDouble rat -> paren (text "Double" <+> rational rat)
- StString str -> paren (text "Str `" <> ptext str <> char '\'')
- StComment str -> paren (text "Comment" <+> ptext str)
StCLbl lbl -> pprCLabel lbl
- StReg reg -> ppStixReg reg
- StIndex k b o -> paren (pprStixTree b <+> char '+' <>
- ppr k <+> pprStixTree o)
- StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']'
- StAssign k d s -> pprStixTree d <> text " :=" <> ppr k
- <> text " " <> pprStixTree s
+ StInt i -> (if i < 0 then parens else id) (integer i)
+ StFloat rat -> parens (text "Float" <+> rational rat)
+ StDouble rat -> parens (text "Double" <+> rational rat)
+ StString str -> parens (text "Str `" <> ftext str <> char '\'')
+ StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
+ ppr k <+> pprStixExpr o)
+ StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
+ StReg reg -> pprStixReg reg
+ StMachOp op args -> pprMachOp op
+ <> parens (hsep (punctuate comma (map pprStixExpr args)))
+ StCall fn cc k args
+ -> parens (text "Call" <+> targ <+>
+ ppr cc <+> ppr k <+>
+ hsep (map pprStixExpr args))
+ where
+ targ = case fn of
+ Left t_static -> ftext t_static
+ Right t_dyn -> parens (pprStixExpr t_dyn)
+
+pprStixStmt :: StixStmt -> SDoc
+pprStixStmt t
+ = case t of
+ StSegment cseg -> parens (ppCodeSegment cseg)
+ StComment str -> parens (text "Comment" <+> ftext str)
+ StAssignReg pr reg rhs
+ -> pprStixReg reg <> text " :=" <> ppr pr
+ <> text " " <> pprStixExpr rhs
+ StAssignMem pr addr rhs
+ -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
+ <> text " :=" <> ppr pr
+ <> text " " <> pprStixExpr rhs
StLabel ll -> pprCLabel ll <+> char ':'
- StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
- StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
- StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
- StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
- StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
- <+> pprStixTree t)
- StData k ds -> paren (text "Data" <+> ppr k <+>
- hsep (map pprStixTree ds))
- StPrim op ts -> paren (text "Prim" <+> ppr op <+>
- hsep (map pprStixTree ts))
- StCall nm cc k args
- -> paren (text "Call" <+> ptext nm <+>
- ppr cc <+> ppr k <+>
- hsep (map pprStixTree args))
- StScratchWord i -> text "ScratchWord" <> paren (int i)
+ StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
+ StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
+ StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
+ StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
+ StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
+ <+> pprStixExpr t)
+ StData k ds -> parens (text "Data" <+> ppr k <+>
+ hsep (map pprStixExpr ds))
+ StDataString str -> parens (text "DataString" <+> ppr str)
+ StVoidable expr -> text "(void)" <+> pprStixExpr expr
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
data StixReg
= StixMagicId MagicId -- Regs which are part of the abstract machine model
- | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
- -- the abstract C.
+ | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
+ -- the abstract C.
+
+pprStixReg (StixMagicId mid) = ppMId mid
+pprStixReg (StixTemp temp) = pprStixVReg temp
+
+repOfStixReg (StixTemp (StixVReg u pr)) = pr
+repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
+
+data StixVReg
+ = StixVReg Unique PrimRep
+
+pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
-ppStixReg (StixMagicId mid)
- = ppMId mid
-ppStixReg (StixTemp u pr)
- = hcat [text "Temp(", ppr u, ppr pr, char ')']
ppMId BaseReg = text "BaseReg"
ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
int (iBox n), char ')']
ppMId Sp = text "Sp"
-ppMId Su = text "Su"
ppMId SpLim = text "SpLim"
ppMId Hp = text "Hp"
ppMId HpLim = text "HpLim"
together).
\begin{code}
-data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
+data CodeSegment
+ = DataSegment
+ | TextSegment
+ | RoDataSegment
+ deriving (Eq, Show)
+
ppCodeSegment = text . show
-type StixTreeList = [StixTree] -> [StixTree]
+type StixStmtList = [StixStmt] -> [StixStmt]
\end{code}
Stix Trees for STG registers:
\begin{code}
-stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
- :: StixTree
-
-stgBaseReg = StReg (StixMagicId BaseReg)
-stgNode = StReg (StixMagicId node)
-stgTagReg = StReg (StixMagicId tagreg)
-stgSp = StReg (StixMagicId Sp)
-stgSu = StReg (StixMagicId Su)
-stgSpLim = StReg (StixMagicId SpLim)
-stgHp = StReg (StixMagicId Hp)
-stgHpLim = StReg (StixMagicId HpLim)
-stgCurrentTSO = StReg (StixMagicId CurrentTSO)
-stgCurrentNursery = StReg (StixMagicId CurrentNursery)
-stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
-stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
+stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim :: StixReg
+
+stgBaseReg = StixMagicId BaseReg
+stgNode = StixMagicId node
+stgTagReg = StixMagicId tagreg
+stgSp = StixMagicId Sp
+stgSpLim = StixMagicId SpLim
+stgHp = StixMagicId Hp
+stgHpLim = StixMagicId HpLim
+stgHpAlloc = StixMagicId HpAlloc
+stgCurrentTSO = StixMagicId CurrentTSO
+stgCurrentNursery = StixMagicId CurrentNursery
+stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
+stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
getNatLabelNCG :: NatM CLabel
getNatLabelNCG
whether or not to inline the assignment's RHS at usage site(s).
\begin{code}
-stixCountTempUses :: Unique -> StixTree -> Int
-stixCountTempUses u t
- = let qq = stixCountTempUses u
+stixExpr_CountTempUses :: Unique -> StixExpr -> Int
+stixExpr_CountTempUses u t
+ = let qs = stixStmt_CountTempUses u
+ qe = stixExpr_CountTempUses u
+ qr = stixReg_CountTempUses u
in
case t of
- StReg reg
- -> case reg of
- StixTemp uu pr -> if u == uu then 1 else 0
- StixMagicId mid -> 0
-
- StIndex pk t1 t2 -> qq t1 + qq t2
- StInd pk t1 -> qq t1
- StAssign pk t1 t2 -> qq t1 + qq t2
- StJump dsts t1 -> qq t1
- StCondJump lbl t1 -> qq t1
- StData pk ts -> sum (map qq ts)
- StPrim op ts -> sum (map qq ts)
- StCall nm cconv pk ts -> sum (map qq ts)
-
- StSegment _ -> 0
+ StReg reg -> qr reg
+ StIndex pk t1 t2 -> qe t1 + qe t2
+ StInd pk t1 -> qe t1
+ StMachOp mop ts -> sum (map qe ts)
+ StCall (Left nm) cconv pk ts -> sum (map qe ts)
+ StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
StInt _ -> 0
StFloat _ -> 0
StDouble _ -> 0
StString _ -> 0
StCLbl _ -> 0
- StLabel _ -> 0
+
+stixStmt_CountTempUses :: Unique -> StixStmt -> Int
+stixStmt_CountTempUses u t
+ = let qe = stixExpr_CountTempUses u
+ qr = stixReg_CountTempUses u
+ qv = stixVReg_CountTempUses u
+ in
+ case t of
+ StAssignReg pk reg rhs -> qr reg + qe rhs
+ StAssignMem pk addr rhs -> qe addr + qe rhs
+ StJump dsts t1 -> qe t1
+ StCondJump lbl t1 -> qe t1
+ StData pk ts -> sum (map qe ts)
+ StVoidable expr -> qe expr
+ StSegment _ -> 0
StFunBegin _ -> 0
StFunEnd _ -> 0
StFallThrough _ -> 0
- StScratchWord _ -> 0
StComment _ -> 0
+ StLabel _ -> 0
+ StDataString _ -> 0
+
+stixReg_CountTempUses u reg
+ = case reg of
+ StixTemp vreg -> stixVReg_CountTempUses u vreg
+ StixMagicId mid -> 0
+stixVReg_CountTempUses u (StixVReg uu pr)
+ = if u == uu then 1 else 0
+\end{code}
-stixSubst :: Unique -> StixTree -> StixTree -> StixTree
-stixSubst u new_u in_this_tree
- = stixMapUniques f in_this_tree
+If we do decide to inline a temporary binding, the following functions
+do the biz.
+
+\begin{code}
+stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
+stixStmt_Subst u new_u in_this_tree
+ = stixStmt_MapUniques f in_this_tree
where
- f :: Unique -> Maybe StixTree
+ f :: Unique -> Maybe StixExpr
f uu = if uu == u then Just new_u else Nothing
-stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
-stixMapUniques f t
- = let qq = stixMapUniques f
+stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
+stixExpr_MapUniques f t
+ = let qe = stixExpr_MapUniques f
+ qs = stixStmt_MapUniques f
+ qr = stixReg_MapUniques f
in
case t of
- StReg reg
- -> case reg of
- StixMagicId mid -> t
- StixTemp uu pr
- -> case f uu of
- Just xx -> xx
- Nothing -> t
-
- StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
- StInd pk t1 -> StInd pk (qq t1)
- StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
- StJump dsts t1 -> StJump dsts (qq t1)
- StCondJump lbl t1 -> StCondJump lbl (qq t1)
- StData pk ts -> StData pk (map qq ts)
- StPrim op ts -> StPrim op (map qq ts)
- StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
-
- StSegment _ -> t
+ StReg reg -> case qr reg of
+ Nothing -> StReg reg
+ Just xx -> xx
+ StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
+ StInd pk t1 -> StInd pk (qe t1)
+ StMachOp mop args -> StMachOp mop (map qe args)
+ StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
+ StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
StInt _ -> t
StFloat _ -> t
StDouble _ -> t
StString _ -> t
StCLbl _ -> t
+
+stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
+stixStmt_MapUniques f t
+ = let qe = stixExpr_MapUniques f
+ qs = stixStmt_MapUniques f
+ qr = stixReg_MapUniques f
+ qv = stixVReg_MapUniques f
+ in
+ case t of
+ StAssignReg pk reg rhs
+ -> case qr reg of
+ Nothing -> StAssignReg pk reg (qe rhs)
+ Just xx -> panic "stixStmt_MapUniques:StAssignReg"
+ StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
+ StJump dsts t1 -> StJump dsts (qe t1)
+ StCondJump lbl t1 -> StCondJump lbl (qe t1)
+ StData pk ts -> StData pk (map qe ts)
+ StVoidable expr -> StVoidable (qe expr)
+ StSegment _ -> t
StLabel _ -> t
StFunBegin _ -> t
StFunEnd _ -> t
StFallThrough _ -> t
- StScratchWord _ -> t
StComment _ -> t
+ StDataString _ -> t
+
+
+stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
+stixReg_MapUniques f reg
+ = case reg of
+ StixMagicId mid -> Nothing
+ StixTemp vreg -> stixVReg_MapUniques f vreg
+
+stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
+stixVReg_MapUniques f (StixVReg uu pr)
+ = f uu
\end{code}
\begin{code}
-data NatM_State = NatM_State UniqSupply Int
+-- Lift StStrings out of top-level StDatas, putting them at the end of
+-- the block, and replacing them with StCLbls which refer to the lifted-out strings.
+{- Motivation for this hackery provided by the following bug:
+ Stix:
+ (DataSegment)
+ Bogon.ping_closure :
+ (Data P_ Addr.A#_static_info)
+ (Data StgAddr (Str `alalal'))
+ (Data P_ (0))
+ results in:
+ .data
+ .align 8
+ .global Bogon_ping_closure
+ Bogon_ping_closure:
+ .long Addr_Azh_static_info
+ .long .Ln1a8
+ .Ln1a8:
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x61
+ .byte 0x6C
+ .byte 0x00
+ .long 0
+ ie, the Str is planted in-line, when what we really meant was to place
+ a _reference_ to the string there. liftStrings will lift out all such
+ strings in top-level data and place them at the end of the block.
+
+ This is still a rather half-baked solution -- to do the job entirely right
+ would mean a complete traversal of all the Stixes, but there's currently no
+ real need for it, and it would be slow. Also, potentially there could be
+ literal types other than strings which need lifting out?
+-}
+
+liftStrings :: [StixStmt] -> UniqSM [StixStmt]
+liftStrings stmts
+ = liftStrings_wrk stmts [] []
+
+liftStrings_wrk :: [StixStmt] -- originals
+ -> [StixStmt] -- (reverse) originals with strings lifted out
+ -> [(CLabel, FastString)] -- lifted strs, and their new labels
+ -> UniqSM [StixStmt]
+
+-- First, examine the original trees and lift out strings in top-level StDatas.
+liftStrings_wrk (st:sts) acc_stix acc_strs
+ = case st of
+ StData sz datas
+ -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
+ liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
+ other
+ -> liftStrings_wrk sts (other:acc_stix) acc_strs
+ where
+ -- Handle a top-level StData
+ lift [] acc_strs = returnUs ([], acc_strs)
+ lift (d:ds) acc_strs
+ = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
+ case d of
+ StString s
+ -> getUniqueUs `thenUs` \ unq ->
+ let lbl = mkAsmTempLabel unq in
+ returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
+ other
+ -> returnUs (other:ds_done, acc_strs1)
+
+-- When we've run out of original trees, emit the lifted strings.
+liftStrings_wrk [] acc_stix acc_strs
+ = returnUs (reverse acc_stix ++ concatMap f acc_strs)
+ where
+ f (lbl,str) = [StSegment RoDataSegment,
+ StLabel lbl,
+ StDataString str,
+ StSegment TextSegment]
+\end{code}
+
+The NCG's monad.
+
+The monad keeps a UniqSupply, the current stack delta and
+a list of imported entities, which is only used for
+Darwin (Mac OS X).
+
+\begin{code}
+data NatM_State = NatM_State UniqSupply Int [FastString]
type NatM result = NatM_State -> (result, NatM_State)
mkNatM_State :: UniqSupply -> Int -> NatM_State
-mkNatM_State = NatM_State
-
-uniqOfNatM_State (NatM_State us delta) = us
-deltaOfNatM_State (NatM_State us delta) = delta
+mkNatM_State us delta = NatM_State us delta []
+uniqOfNatM_State (NatM_State us delta imports) = us
+deltaOfNatM_State (NatM_State us delta imports) = delta
+importsOfNatM_State (NatM_State us delta imports) = imports
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m = case m init_st of { (r,st) -> (r,st) }
getUniqueNat :: NatM Unique
-getUniqueNat (NatM_State us delta)
+getUniqueNat (NatM_State us delta imports)
= case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
+ (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
getDeltaNat :: NatM Int
-getDeltaNat st@(NatM_State us delta)
+getDeltaNat st@(NatM_State us delta imports)
= (delta, st)
setDeltaNat :: Int -> NatM ()
-setDeltaNat delta (NatM_State us _)
- = ((), NatM_State us delta)
+setDeltaNat delta (NatM_State us _ imports)
+ = ((), NatM_State us delta imports)
+
+addImportNat :: FastString -> NatM ()
+addImportNat imp (NatM_State us delta imports)
+ = ((), NatM_State us delta (imp:imports))
\end{code}
Giving up in a not-too-inelegant way.
`seq`
pprPanic msg pp_rep
\end{code}
+
+Information about the target.
+
+\begin{code}
+
+ncg_target_is_32bit :: Bool
+ncg_target_is_32bit | wORD_SIZE == 4 = True
+ | wORD_SIZE == 8 = False
+
+\end{code}