CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
+ DestInfo(..), hasDestInfo,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
uniqOfNatM_State, deltaOfNatM_State,
getUniqLabelNCG, getNatLabelNCG,
+ ncgPrimopMoan
) where
#include "HsVersions.h"
import Ratio ( Rational )
+import IOExts ( unsafePerformIO )
+import IO ( hPutStrLn, stderr )
import AbsCSyn ( node, tagreg, MagicId(..) )
-import AbsCUtils ( magicIdPrimRep )
-import CallConv ( CallConv, pprCallConv )
-import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm )
-import PrimRep ( PrimRep(..), showPrimRep )
-import PrimOp ( PrimOp, pprPrimOp )
+import ForeignCall ( CCallConv )
+import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
+import PrimRep ( PrimRep(..) )
+import PrimOp ( PrimOp )
import Unique ( Unique )
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
-import CmdLineOpts ( opt_Static )
import Outputable
+import FastTypes
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
-- We can tag the leaves with constants/immediates.
| StInt Integer -- ** add Kind at some point
+ | StFloat Rational
| StDouble Rational
| StString FAST_STRING
| StCLbl CLabel -- labels that we might index into
| StFunBegin CLabel
| StFunEnd CLabel
- -- An unconditional jump. This instruction is terminal.
- -- Dynamic targets are allowed
+ -- An unconditional jump. This instruction may or may not jump
+ -- out of the register allocation domain (basic block, more or
+ -- less). For correct register allocation when this insn is used
+ -- to jump through a jump table, we optionally allow a list of
+ -- 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 StixTree
+ | StJump DestInfo StixTree
-- A fall-through, from slow to fast
-- Calls to C functions
- | StCall FAST_STRING CallConv PrimRep [StixTree]
+ | StCall FAST_STRING CCallConv PrimRep [StixTree]
-- A volatile memory scratch array, which is allocated
-- relative to the stack pointer. It is an array of
| StComment FAST_STRING
+-- used by insnFuture in RegAllocInfo.lhs
+data DestInfo
+ = NoDestInfo -- no supplied dests; infer from context
+ | DestInfo [CLabel] -- precisely these dests and no others
+
+hasDestInfo NoDestInfo = False
+hasDestInfo (DestInfo _) = True
+
+pprDests :: DestInfo -> SDoc
+pprDests NoDestInfo = text "NoDestInfo"
+pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
+
+
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
]
paren t = char '(' <> t <> char ')'
+brack t = char '[' <> t <> char ']'
pprStixTree :: StixTree -> SDoc
pprStixTree 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)
+ 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 '+' <>
- pprPrimRep k <+> pprStixTree o)
- StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
- StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
+ 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
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
- StJump t -> paren (text "Jump" <+> pprStixTree t)
+ 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" <+> pprPrimRep k <+>
+ StData k ds -> paren (text "Data" <+> ppr k <+>
hsep (map pprStixTree ds))
- StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
+ StPrim op ts -> paren (text "Prim" <+> ppr op <+>
hsep (map pprStixTree ts))
StCall nm cc k args
-> paren (text "Call" <+> ptext nm <+>
- pprCallConv cc <+> pprPrimRep k <+>
+ ppr cc <+> ppr k <+>
hsep (map pprStixTree args))
StScratchWord i -> text "ScratchWord" <> paren (int i)
-
-pprPrimRep = text . showPrimRep
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
ppMId BaseReg = text "BaseReg"
-ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
- int (I# n), char ')']
-ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
-ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
-ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
- int (I# n), char ')']
+ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
+ int (iBox n), char ')']
+ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
+ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), 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"
together).
\begin{code}
-data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
+data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
ppCodeSegment = text . show
type StixTreeList = [StixTree] -> [StixTree]
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)))
+stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
+stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
getNatLabelNCG :: NatM CLabel
getNatLabelNCG
StIndex pk t1 t2 -> qq t1 + qq t2
StInd pk t1 -> qq t1
StAssign pk t1 t2 -> qq t1 + qq t2
- StJump t1 -> qq t1
+ StJump dsts t1 -> qq t1
StCondJump lbl t1 -> qq t1
StData pk ts -> sum (map qq ts)
StPrim op ts -> sum (map qq ts)
StSegment _ -> 0
StInt _ -> 0
+ StFloat _ -> 0
StDouble _ -> 0
StString _ -> 0
StCLbl _ -> 0
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 t1 -> StJump (qq t1)
+ 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)
StSegment _ -> t
StInt _ -> t
+ StFloat _ -> t
StDouble _ -> t
StString _ -> t
StCLbl _ -> t
setDeltaNat delta (NatM_State us _)
= ((), NatM_State us delta)
\end{code}
+
+Giving up in a not-too-inelegant way.
+
+\begin{code}
+ncgPrimopMoan :: String -> SDoc -> a
+ncgPrimopMoan msg pp_rep
+ = unsafePerformIO (
+ hPutStrLn stderr (
+ "\n" ++
+ "You've fallen across an unimplemented case in GHC's native code generation\n" ++
+ "machinery. You can work around this for the time being by compiling\n" ++
+ "this module via the C route, by giving the flag -fvia-C.\n" ++
+ "The panic below contains information, intended for the GHC implementors,\n" ++
+ "about the exact place where GHC gave up. Please send it to us\n" ++
+ "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
+ )
+ )
+ `seq`
+ pprPanic msg pp_rep
+\end{code}
projects / ghc-hetmet.git / blobdiff