StixStmt(..), mkStAssign, StixStmtList,
pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
stixStmt_CountTempUses, stixStmt_Subst,
- liftStrings,
+ liftStrings, repOfStixExpr,
DestInfo(..), hasDestInfo,
- stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
+ stgBaseReg, stgNode, stgSp, stgSpLim,
stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
stgCurrentTSO, stgCurrentNursery,
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 MachOp ( MachOp(..), pprMachOp )
+import MachOp ( MachOp(..), pprMachOp, resultRepOfMachOp )
import Unique ( Unique )
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
-import Maybes ( Maybe012(..), maybe012ToList )
+import Constants ( wORD_SIZE )
import Outputable
import FastTypes
+import FastString
+
+import UNSAFE_IO ( unsafePerformIO )
+
+import Ratio ( Rational )
+import IO ( hPutStrLn, stderr )
\end{code}
Two types, StixStmt and StixValue, define Stix.
StSegment CodeSegment
-- Assembly-language comments
- | StComment FAST_STRING
+ | StComment FastString
-- Assignments are typed to determine size and register placement.
-- Assign a value to a StixReg
-- assigned to, so there is an implicit dereference here.
| StAssignMem PrimRep StixExpr StixExpr -- dst, src
- -- Do a machine op which generates multiple values, and assign
- -- the results to the lvalues stated here.
- | StAssignMachOp (Maybe012 StixVReg) MachOp [StixExpr]
-
-- A simple assembly label that we might jump to.
| StLabel CLabel
-- Raw data (as in an info table).
| StData PrimRep [StixExpr]
-- String which has been lifted to the top level (sigh).
- | StDataString FAST_STRING
+ | 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
isCloseEnoughTo r1 r2
= r1 == r2 || (wordIsh r1 && wordIsh r2)
wordIsh rep
- = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep,
- RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep]
+ = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ]
-- determined by looking at PrimRep.showPrimRep
-- Stix trees which denote a value.
StInt Integer -- ** add Kind at some point
| StFloat Rational
| StDouble Rational
- | StString FAST_STRING
+ | StString FastString
| StCLbl CLabel -- labels that we might index into
-- Abstract registers of various kinds
| StMachOp MachOp [StixExpr]
-- Calls to C functions
- | StCall FAST_STRING CCallConv PrimRep [StixExpr]
+ | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic
+ CCallConv PrimRep [StixExpr]
+
+
+-- 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
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 `" <> ptext str <> char '\'')
+ 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 nm cc k args
- -> parens (text "Call" <+> ptext nm <+>
+ 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" <+> ptext str)
+ StComment str -> parens (text "Comment" <+> ftext str)
StAssignReg pr reg rhs
-> pprStixReg reg <> text " :=" <> ppr pr
<> text " " <> pprStixExpr rhs
-> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
<> text " :=" <> ppr pr
<> text " " <> pprStixExpr rhs
- StAssignMachOp lhss mop args
- -> parens (hcat (punctuate comma (
- map pprStixVReg (maybe012ToList lhss)
- )))
- <> text " := "
- <> pprMachOp mop
- <> parens (hsep (punctuate comma (map pprStixExpr args)))
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
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, ppr pr, char ')']
+pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
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"
Stix Trees for STG registers:
\begin{code}
-stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
- :: StixReg
+stgBaseReg, stgNode, stgSp, stgSpLim, stgHp, stgHpLim :: StixReg
stgBaseReg = StixMagicId BaseReg
stgNode = StixMagicId node
stgTagReg = StixMagicId tagreg
stgSp = StixMagicId Sp
-stgSu = StixMagicId Su
stgSpLim = StixMagicId SpLim
stgHp = StixMagicId Hp
stgHpLim = StixMagicId HpLim
StIndex pk t1 t2 -> qe t1 + qe t2
StInd pk t1 -> qe t1
StMachOp mop ts -> sum (map qe ts)
- StCall nm cconv pk 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
StJump dsts t1 -> qe t1
StCondJump lbl t1 -> qe t1
StData pk ts -> sum (map qe ts)
- StAssignMachOp lhss mop args
- -> sum (map qv (maybe012ToList lhss)) + sum (map qe args)
StVoidable expr -> qe expr
StSegment _ -> 0
StFunBegin _ -> 0
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 nm cconv pk ts -> StCall nm cconv pk (map qe ts)
+ 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
qs = stixStmt_MapUniques f
qr = stixReg_MapUniques f
qv = stixVReg_MapUniques f
-
- doMopLhss Just0 = Just0
- doMopLhss (Just1 r1)
- = case qv r1 of
- Nothing -> Just1 r1
- other -> doMopLhss_panic
- doMopLhss (Just2 r1 r2)
- = case (qv r1, qv r2) of
- (Nothing, Nothing) -> Just2 r1 r2
- other -> doMopLhss_panic
- -- Because the StixRegs processed by doMopLhss are lvalues, they
- -- absolutely shouldn't be mapped to a StixExpr;
- -- hence we panic if they do. Same deal for StAssignReg below.
- doMopLhss_panic
- = panic "stixStmt_MapUniques:doMopLhss"
in
case t of
StAssignReg pk reg 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)
- StAssignMachOp lhss mop args
- -> StAssignMachOp (doMopLhss lhss) mop (map qe args)
+ StVoidable expr -> StVoidable (qe expr)
StSegment _ -> t
StLabel _ -> t
StFunBegin _ -> t
liftStrings_wrk :: [StixStmt] -- originals
-> [StixStmt] -- (reverse) originals with strings lifted out
- -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
+ -> [(CLabel, FastString)] -- lifted strs, and their new labels
-> UniqSM [StixStmt]
-- First, examine the original trees and lift out strings in top-level StDatas.
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
+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}
projects / ghc-hetmet.git / blobdiff