summaryrefslogtreecommitdiff
path: root/ghc/compiler/nativeGen
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/nativeGen')
-rw-r--r--ghc/compiler/nativeGen/AbsCStixGen.lhs5
-rw-r--r--ghc/compiler/nativeGen/AsmCodeGen.lhs21
-rw-r--r--ghc/compiler/nativeGen/AsmRegAlloc.lhs4
-rw-r--r--ghc/compiler/nativeGen/MachCode.lhs96
-rw-r--r--ghc/compiler/nativeGen/MachMisc.hi-boot8
-rw-r--r--ghc/compiler/nativeGen/MachMisc.lhs56
-rw-r--r--ghc/compiler/nativeGen/MachRegs.lhs23
-rw-r--r--ghc/compiler/nativeGen/NcgLoop.hs12
-rw-r--r--ghc/compiler/nativeGen/PprMach.lhs766
-rw-r--r--ghc/compiler/nativeGen/RegAllocInfo.lhs11
-rw-r--r--ghc/compiler/nativeGen/Stix.hi-boot5
-rw-r--r--ghc/compiler/nativeGen/Stix.lhs11
-rw-r--r--ghc/compiler/nativeGen/StixInfo.lhs20
-rw-r--r--ghc/compiler/nativeGen/StixInteger.lhs4
-rw-r--r--ghc/compiler/nativeGen/StixMacro.lhs4
-rw-r--r--ghc/compiler/nativeGen/StixPrim.hi-boot5
-rw-r--r--ghc/compiler/nativeGen/StixPrim.lhs12
17 files changed, 592 insertions, 471 deletions
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 864b2f3a2f..7dcc67f15a 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -14,12 +14,17 @@ import AbsCSyn
import Stix
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
import Constants ( mIN_UPD_SIZE )
+import CLabel ( CLabel )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
)
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 3a87fecb4f..fad3653203 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -11,7 +11,11 @@ IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(Handle))
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import MachCode
import PprMach
@@ -23,8 +27,9 @@ import PrimOp ( commutableOp, PrimOp(..) )
import PrimRep ( PrimRep{-instance Eq-} )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
-import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) )
-import Unpretty ( uppPutStr, uppShow, uppAboves, SYN_IE(Unpretty) )
+import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM), UniqSupply )
+import Outputable ( printDoc )
+import Pretty ( Doc, vcat, Mode(..) )
\end{code}
The 96/03 native-code generator has machine-independent and
@@ -59,7 +64,7 @@ The machine-dependent bits break down as follows:
machine instructions.
\item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really
- an @Unpretty@).
+ an @Doc@).
\item[@RegAllocInfo@:] In the register allocator, we manipulate
@MRegsState@s, which are @BitSet@s, one bit per machine register.
@@ -75,13 +80,11 @@ The machine-dependent bits break down as follows:
So, here we go:
\begin{code}
writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
-
writeRealAsm handle absC us
- = _scc_ "writeRealAsm" (uppPutStr handle 80 (runNCG absC us))
+ = _scc_ "writeRealAsm" (printDoc LeftMode handle (runNCG absC us))
dumpRealAsm :: AbstractC -> UniqSupply -> String
-
-dumpRealAsm absC us = uppShow 80 (runNCG absC us)
+dumpRealAsm absC us = show (runNCG absC us)
runNCG absC
= genCodeAbstractC absC `thenUs` \ treelists ->
@@ -93,14 +96,14 @@ runNCG absC
@codeGen@ is the top-level code-generation function:
\begin{code}
-codeGen :: [[StixTree]] -> UniqSM Unpretty
+codeGen :: [[StixTree]] -> UniqSM Doc
codeGen trees
= mapUs genMachCode trees `thenUs` \ dynamic_codes ->
let
static_instrs = scheduleMachCode dynamic_codes
in
- returnUs (uppAboves (map pprInstr static_instrs))
+ returnUs (vcat (map pprInstr static_instrs))
\end{code}
Top level code generator for a chunk of stix code:
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index b7e85f8eb1..54af675efc 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -12,7 +12,11 @@ IMP_Ubiq(){-uitous-}
import MachCode ( SYN_IE(InstrList) )
import MachMisc ( Instr )
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import RegAllocInfo
import AbsCSyn ( MagicId )
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index de2bb90474..5b5833acf4 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -17,23 +17,34 @@ module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
IMP_Ubiq(){-uitious-}
import MachMisc -- may differ per-platform
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr(..))
+import qualified MachRegs (Addr(..))
+#define MachRegsAddr MachRegs.Addr
+#define MachRegsAddrRegImm MachRegs.AddrRegImm
+#define MachRegsAddrRegReg MachRegs.AddrRegReg
+#else
import MachRegs
+#define MachRegsAddr Addr
+#define MachRegsAddrRegImm AddrRegImm
+#define MachRegsAddrRegReg AddrRegReg
+#endif
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( isAsmTemp )
+import CLabel ( isAsmTemp, CLabel )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
-import Pretty ( prettyToUn, ppRational )
+import PprStyle
+import Pretty ( ptext, rational )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..) )
+import PrimOp ( PrimOp(..), showPrimOp )
import Stix ( getUniqLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..)
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
mapAccumLUs, SYN_IE(UniqSM)
)
-import Unpretty ( uppPStr )
import Util ( panic, assertPanic )
\end{code}
@@ -274,7 +285,7 @@ getRegister (StDouble d)
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA TF [ImmLab (prettyToUn (ppRational d))],
+ DATA TF [ImmLab (rational d)],
SEGMENT TextSegment,
LDA tmp (AddrImm (ImmCLbl lbl)),
LD TF dst (AddrReg tmp)]
@@ -674,7 +685,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
in
returnUs (Any IntRep code__2)
@@ -731,7 +742,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
in
returnUs (Any IntRep code__2)
@@ -746,7 +757,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
in
returnUs (Any IntRep code__2)
@@ -789,10 +800,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
src2 = ImmInt (fromInteger i)
code__2 = asmParThen [code1] .
mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
@@ -812,10 +823,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
CLTD,
IDIV sz (OpReg src2)]
else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
MOV L (OpReg src1) (OpReg eax),
CLTD,
- IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
@@ -864,7 +875,7 @@ getRegister (StDouble d)
DATA DF [dblImmLit d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
- LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+ LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst]
in
returnUs (Any DoubleRep code)
@@ -872,10 +883,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (SUB False False g0) x
IntAbsOp -> absIntCode x
-
NotOp -> trivialUCode (XNOR False g0) x
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
+
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
@@ -901,6 +912,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
FloatExpOp -> (True, SLIT("exp"))
FloatLogOp -> (True, SLIT("log"))
+ FloatSqrtOp -> (True, SLIT("sqrt"))
FloatSinOp -> (True, SLIT("sin"))
FloatCosOp -> (True, SLIT("cos"))
@@ -916,6 +928,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
+ DoubleSqrtOp -> (True, SLIT("sqrt"))
DoubleSinOp -> (False, SLIT("sin"))
DoubleCosOp -> (False, SLIT("cos"))
@@ -928,6 +941,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
+ _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
@@ -1048,7 +1062,7 @@ getRegister leaf
@Amode@s: Memory addressing modes passed up the tree.
\begin{code}
-data Amode = Amode Addr InstrBlock
+data Amode = Amode MachRegsAddr InstrBlock
amodeAddr (Amode addr _) = addr
amodeCode (Amode _ code) = code
@@ -1072,7 +1086,7 @@ getAmode (StPrim IntSubOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
= getNewRegNCG PtrRep `thenUs` \ tmp ->
@@ -1082,7 +1096,7 @@ getAmode (StPrim IntAddOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode leaf
| maybeToBool imm
@@ -1112,7 +1126,7 @@ getAmode (StPrim IntSubOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, StInt i])
| maybeToBool imm
@@ -1132,7 +1146,7 @@ getAmode (StPrim IntAddOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (Addr (Just reg) Nothing off) code)
+ returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
getAmode (StPrim IntAddOp [x, y])
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
@@ -1146,7 +1160,7 @@ getAmode (StPrim IntAddOp [x, y])
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
getAmode leaf
| maybeToBool imm
@@ -1166,7 +1180,7 @@ getAmode other
reg = registerName register tmp
off = Nothing
in
- returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+ returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -1181,7 +1195,7 @@ getAmode (StPrim IntSubOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (-(fromInteger i))
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, StInt i])
@@ -1193,7 +1207,7 @@ getAmode (StPrim IntAddOp [x, StInt i])
reg = registerName register tmp
off = ImmInt (fromInteger i)
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
getAmode (StPrim IntAddOp [x, y])
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
@@ -1207,7 +1221,7 @@ getAmode (StPrim IntAddOp [x, y])
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
in
- returnUs (Amode (AddrRegReg reg1 reg2) code__2)
+ returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2)
getAmode leaf
| maybeToBool imm
@@ -1215,7 +1229,7 @@ getAmode leaf
let
code = mkSeqInstr (SETHI (HI imm__2) tmp)
in
- returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
+ returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
@@ -1228,7 +1242,7 @@ getAmode other
reg = registerName register tmp
off = ImmInt 0
in
- returnUs (Amode (AddrRegImm reg off) code)
+ returnUs (Amode (MachRegsAddrRegImm reg off) code)
#endif {- sparc_TARGET_ARCH -}
\end{code}
@@ -1923,7 +1937,7 @@ genJump tree
code = registerCode register tmp
target = registerName register tmp
in
- returnSeq code [JMP (AddrRegReg target g0), NOP]
+ returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
#endif {- sparc_TARGET_ARCH -}
\end{code}
@@ -2164,7 +2178,7 @@ genCCall fn kind args
code = asmParThen (map ($ asmVoid) argCode)
in
returnSeq code [
- LDA pv (AddrImm (ImmLab (uppPStr fn))),
+ LDA pv (AddrImm (ImmLab (ptext fn))),
JSR ra (AddrReg pv) nRegs,
LDGP gp (AddrReg ra)]
where
@@ -2231,8 +2245,8 @@ genCCall fn kind [StInt i]
call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
MOV L (OpImm (ImmCLbl lbl))
-- this is hardwired
- (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (uppPStr (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
+ (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
LABEL lbl]
in
returnInstrs call
@@ -2241,14 +2255,14 @@ genCCall fn kind args
= mapUs get_call_arg args `thenUs` \ argCode ->
let
nargs = length args
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
]
]
code2 = asmParThen (map ($ asmVoid) (reverse argCode))
call = [CALL fn__2 -- ,
-- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
- -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
]
in
returnSeq (code1 . code2) call
@@ -2258,8 +2272,8 @@ genCCall fn kind args
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------
get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
@@ -2316,8 +2330,8 @@ genCCall fn kind args
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (uppPStr fn)
- _ -> ImmLab (uppPStr fn)
+ '.' -> ImmLit (ptext fn)
+ _ -> ImmLab (ptext fn)
------------------------------------
{- Try to get a value into a specific register (or registers) for
@@ -3045,8 +3059,8 @@ coerceInt2FP pk x
code__2 dst = code . mkSeqInstrs [
-- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
in
returnUs (Any pk code__2)
@@ -3062,8 +3076,8 @@ coerceFP2Int x
code__2 dst = let
in code . mkSeqInstrs [
FRNDINT,
- FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
+ MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
in
returnUs (Any IntRep code__2)
diff --git a/ghc/compiler/nativeGen/MachMisc.hi-boot b/ghc/compiler/nativeGen/MachMisc.hi-boot
new file mode 100644
index 0000000000..e12bce6df5
--- /dev/null
+++ b/ghc/compiler/nativeGen/MachMisc.hi-boot
@@ -0,0 +1,8 @@
+_interface_ MachMisc 1
+_exports_
+MachMisc fixedHdrSizeInWords fmtAsmLbl varHdrSizeInWords underscorePrefix;
+_declarations_
+1 fixedHdrSizeInWords _:_ PrelBase.Int ;;
+2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;;
+1 varHdrSizeInWords _:_ SMRep.SMRep -> PrelBase.Int ;;
+1 underscorePrefix _:_ PrelBase.Bool ;;
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index a3eb463b1f..58ce3b4c85 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -48,11 +48,21 @@ IMPORT_1_3(Char(isDigit))
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
+import CLabel ( CLabel )
import CmdLineOpts ( opt_SccProfilingOn )
import Literal ( mkMachInt, Literal(..) )
import MachRegs ( stgReg, callerSaves, RegLoc(..),
- Imm(..), Reg(..), Addr
+ Imm(..), Reg(..)
+#if __GLASGOW_HASKELL__ >= 202
+ )
+import qualified MachRegs (Addr)
+#define MachRegsAddr MachRegs.Addr
+#else
+ , Addr(..)
)
+#define MachRegsAddr Addr
+#endif
+
import OrdList ( OrdList )
import PrimRep ( PrimRep(..) )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
@@ -436,12 +446,12 @@ data Instr
-- Loads and stores.
- | LD Size Reg Addr -- size, dst, src
- | LDA Reg Addr -- dst, src
- | LDAH Reg Addr -- dst, src
- | LDGP Reg Addr -- dst, src
+ | LD Size Reg MachRegsAddr -- size, dst, src
+ | LDA Reg MachRegsAddr -- dst, src
+ | LDAH Reg MachRegsAddr -- dst, src
+ | LDGP Reg MachRegsAddr -- dst, src
| LDI Size Reg Imm -- size, dst, src
- | ST Size Reg Addr -- size, src, dst
+ | ST Size Reg MachRegsAddr -- size, src, dst
-- Int Arithmetic.
@@ -496,9 +506,9 @@ data Instr
| BI Cond Reg Imm
| BF Cond Reg Imm
| BR Imm
- | JMP Reg Addr Int
+ | JMP Reg MachRegsAddr Int
| BSR Imm Int
- | JSR Reg Addr Int
+ | JSR Reg MachRegsAddr Int
-- Alpha-specific pseudo-ops.
@@ -559,25 +569,25 @@ data RI
| FABS
| FADD Size Operand -- src
| FADDP
- | FIADD Size Addr -- src
+ | FIADD Size MachRegsAddr -- src
| FCHS
| FCOM Size Operand -- src
| FCOS
| FDIV Size Operand -- src
| FDIVP
- | FIDIV Size Addr -- src
+ | FIDIV Size MachRegsAddr -- src
| FDIVR Size Operand -- src
| FDIVRP
- | FIDIVR Size Addr -- src
- | FICOM Size Addr -- src
- | FILD Size Addr Reg -- src, dst
- | FIST Size Addr -- dst
+ | FIDIVR Size MachRegsAddr -- src
+ | FICOM Size MachRegsAddr -- src
+ | FILD Size MachRegsAddr Reg -- src, dst
+ | FIST Size MachRegsAddr -- dst
| FLD Size Operand -- src
| FLD1
| FLDZ
| FMUL Size Operand -- src
| FMULP
- | FIMUL Size Addr -- src
+ | FIMUL Size MachRegsAddr -- src
| FRNDINT
| FSIN
| FSQRT
@@ -585,10 +595,10 @@ data RI
| FSTP Size Operand -- dst
| FSUB Size Operand -- src
| FSUBP
- | FISUB Size Addr -- src
+ | FISUB Size MachRegsAddr -- src
| FSUBR Size Operand -- src
| FSUBRP
- | FISUBR Size Addr -- src
+ | FISUBR Size MachRegsAddr -- src
| FTST
| FCOMP Size Operand -- src
| FUCOMPP
@@ -618,9 +628,9 @@ data RI
| CLTD -- sign extend %eax into %edx:%eax
data Operand
- = OpReg Reg -- register
- | OpImm Imm -- immediate value
- | OpAddr Addr -- memory reference
+ = OpReg Reg -- register
+ | OpImm Imm -- immediate value
+ | OpAddr MachRegsAddr -- memory reference
#endif {- i386_TARGET_ARCH -}
\end{code}
@@ -632,8 +642,8 @@ data Operand
-- Loads and stores.
- | LD Size Addr Reg -- size, src, dst
- | ST Size Reg Addr -- size, src, dst
+ | LD Size MachRegsAddr Reg -- size, src, dst
+ | ST Size Reg MachRegsAddr -- size, src, dst
-- Int Arithmetic.
@@ -675,7 +685,7 @@ data Operand
| BI Cond Bool Imm -- cond, annul?, target
| BF Cond Bool Imm -- cond, annul?, target
- | JMP Addr -- target
+ | JMP MachRegsAddr -- target
| CALL Imm Int Bool -- target, args, terminal
data RI = RIReg Reg
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 19ad5718cb..2baaf71728 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -59,11 +59,19 @@ module MachRegs (
#endif
) where
+#if __GLASGOW_HASKELL__ >= 202
+import GlaExts hiding (Addr)
+import FastString
+import Ubiq
+#else
IMP_Ubiq(){-uitous-}
+#endif
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
-import Pretty ( ppStr, ppRational, ppShow )
+import CLabel ( CLabel )
+import Outputable ( Outputable(..) )
+import Pretty ( Doc, text, rational )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix ( sStLitLbl, StixTree(..), StixReg(..),
@@ -73,8 +81,7 @@ import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppStr, SYN_IE(Unpretty) )
-import Util ( panic )
+import Util ( panic, Ord3(..) )
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -84,20 +91,20 @@ data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
- | ImmLab Unpretty -- Simple string label (underscore-able)
- | ImmLit Unpretty -- Simple string
+ | ImmLab Doc -- Simple string label (underscore-able)
+ | ImmLit Doc -- Simple string
IF_ARCH_sparc(
| LO Imm -- Possible restrictions...
| HI Imm
,)
-strImmLit s = ImmLit (uppStr s)
+strImmLit s = ImmLit (text s)
dblImmLit r
= strImmLit (
IF_ARCH_alpha({-prepend nothing-}
,IF_ARCH_i386( '0' : 'd' :
,IF_ARCH_sparc('0' : 'r' :,)))
- ppShow 80 (ppRational r))
+ show (rational r))
\end{code}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -307,7 +314,7 @@ instance Text Reg where
#ifdef DEBUG
instance Outputable Reg where
- ppr sty r = ppStr (show r)
+ ppr sty r = text (show r)
#endif
cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i'
diff --git a/ghc/compiler/nativeGen/NcgLoop.hs b/ghc/compiler/nativeGen/NcgLoop.hs
new file mode 100644
index 0000000000..009107bdb7
--- /dev/null
+++ b/ghc/compiler/nativeGen/NcgLoop.hs
@@ -0,0 +1,12 @@
+module NcgLoop
+
+ (
+ module StixPrim,
+ module MachMisc,
+ module Stix
+ ) where
+
+import StixPrim
+import MachMisc
+import Stix
+
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 9b2cd26b7c..80c0c0251a 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -13,9 +13,18 @@ We start with the @pprXXX@s with some cross-platform commonality
module PprMach ( pprInstr ) where
-IMP_Ubiq(){-uitious-}
IMPORT_1_3(Char(isPrint,isDigit))
-IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards
+#if __GLASGOW_HASKELL__ == 201
+import qualified GHCbase(Addr(..)) -- to see innards
+IMP_Ubiq(){-uitious-}
+#elif __GLASGOW_HASKELL__ >= 202
+import qualified GlaExts (Addr(..))
+import GlaExts hiding (Addr(..))
+import FastString
+import Ubiq
+#else
+IMP_Ubiq(){-uitious-}
+#endif
import MachRegs -- may differ per-platform
import MachMisc
@@ -26,11 +35,14 @@ import CStrings ( charToC )
import Maybes ( maybeToBool )
import OrdList ( OrdList )
import Stix ( CodeSegment(..), StixTree )
-import Unpretty -- all of it
+import Pretty -- all of it
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
a_HASH x = GHCbase.A# x
pACK_STR x = packCString x
+#elif __GLASGOW_HASKELL__ >= 202
+a_HASH x = GlaExts.A# x
+pACK_STR x = mkFastCharString x
#else
a_HASH x = A# x
pACK_STR x = mkFastCharString x --_packCString x
@@ -46,17 +58,17 @@ pACK_STR x = mkFastCharString x --_packCString x
For x86, the way we print a register name depends
on which bit of it we care about. Yurgh.
\begin{code}
-pprReg :: IF_ARCH_i386(Size ->,) Reg -> Unpretty
+pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
pprReg IF_ARCH_i386(s,) r
= case r of
FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i
- other -> uppStr (show other) -- should only happen when debugging
+ other -> text (show other) -- should only happen when debugging
where
#if alpha_TARGET_ARCH
- ppr_reg_no :: FAST_REG_NO -> Unpretty
- ppr_reg_no i = uppPStr
+ ppr_reg_no :: FAST_REG_NO -> Doc
+ ppr_reg_no i = ptext
(case i of {
ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1");
ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3");
@@ -94,8 +106,8 @@ pprReg IF_ARCH_i386(s,) r
})
#endif
#if i386_TARGET_ARCH
- ppr_reg_no :: Size -> FAST_REG_NO -> Unpretty
- ppr_reg_no B i = uppPStr
+ ppr_reg_no :: Size -> FAST_REG_NO -> Doc
+ ppr_reg_no B i = ptext
(case i of {
ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
@@ -103,7 +115,7 @@ pprReg IF_ARCH_i386(s,) r
})
{- UNUSED:
- ppr_reg_no HB i = uppPStr
+ ppr_reg_no HB i = ptext
(case i of {
ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
@@ -112,7 +124,7 @@ pprReg IF_ARCH_i386(s,) r
-}
{- UNUSED:
- ppr_reg_no S i = uppPStr
+ ppr_reg_no S i = ptext
(case i of {
ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
@@ -122,7 +134,7 @@ pprReg IF_ARCH_i386(s,) r
})
-}
- ppr_reg_no L i = uppPStr
+ ppr_reg_no L i = ptext
(case i of {
ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
@@ -131,7 +143,7 @@ pprReg IF_ARCH_i386(s,) r
_ -> SLIT("very naughty I386 double word register")
})
- ppr_reg_no F i = uppPStr
+ ppr_reg_no F i = ptext
(case i of {
--ToDo: rm these (???)
ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
@@ -141,7 +153,7 @@ pprReg IF_ARCH_i386(s,) r
_ -> SLIT("very naughty I386 float register")
})
- ppr_reg_no DF i = uppPStr
+ ppr_reg_no DF i = ptext
(case i of {
--ToDo: rm these (???)
ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
@@ -152,8 +164,8 @@ pprReg IF_ARCH_i386(s,) r
})
#endif
#if sparc_TARGET_ARCH
- ppr_reg_no :: FAST_REG_NO -> Unpretty
- ppr_reg_no i = uppPStr
+ ppr_reg_no :: FAST_REG_NO -> Doc
+ ppr_reg_no i = ptext
(case i of {
ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1");
ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3");
@@ -199,9 +211,9 @@ pprReg IF_ARCH_i386(s,) r
%************************************************************************
\begin{code}
-pprSize :: Size -> Unpretty
+pprSize :: Size -> Doc
-pprSize x = uppPStr (case x of
+pprSize x = ptext (case x of
#if alpha_TARGET_ARCH
B -> SLIT("b")
BU -> SLIT("bu")
@@ -232,6 +244,17 @@ pprSize x = uppPStr (case x of
F -> SLIT("")
-- D -> SLIT("d") UNUSED
DF -> SLIT("d")
+ )
+pprStSize :: Size -> Doc
+pprStSize x = ptext (case x of
+ B -> SLIT("b")
+ BU -> SLIT("b")
+-- HW -> SLIT("hw") UNUSED
+-- HWU -> SLIT("uhw") UNUSED
+ W -> SLIT("")
+ F -> SLIT("")
+-- D -> SLIT("d") UNUSED
+ DF -> SLIT("d")
#endif
)
\end{code}
@@ -243,9 +266,9 @@ pprSize x = uppPStr (case x of
%************************************************************************
\begin{code}
-pprCond :: Cond -> Unpretty
+pprCond :: Cond -> Doc
-pprCond c = uppPStr (case c of {
+pprCond c = ptext (case c of {
#if alpha_TARGET_ARCH
EQQ -> SLIT("eq");
LTT -> SLIT("lt");
@@ -285,26 +308,26 @@ pprCond c = uppPStr (case c of {
%************************************************************************
\begin{code}
-pprImm :: Imm -> Unpretty
+pprImm :: Imm -> Doc
-pprImm (ImmInt i) = uppInt i
-pprImm (ImmInteger i) = uppInteger i
+pprImm (ImmInt i) = int i
+pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = pprCLabel_asm l
pprImm (ImmLit s) = s
-pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s
+pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s
| otherwise = s
#if sparc_TARGET_ARCH
pprImm (LO i)
- = uppBesides [ pp_lo, pprImm i, uppRparen ]
+ = hcat [ pp_lo, pprImm i, rparen ]
where
- pp_lo = uppPStr (pACK_STR (a_HASH "%lo("#))
+ pp_lo = ptext (pACK_STR (a_HASH "%lo("#))
pprImm (HI i)
- = uppBesides [ pp_hi, pprImm i, uppRparen ]
+ = hcat [ pp_hi, pprImm i, rparen ]
where
- pp_hi = uppPStr (pACK_STR (a_HASH "%hi("#))
+ pp_hi = ptext (pACK_STR (a_HASH "%hi("#))
#endif
\end{code}
@@ -315,13 +338,13 @@ pprImm (HI i)
%************************************************************************
\begin{code}
-pprAddr :: Addr -> Unpretty
+pprAddr :: Addr -> Doc
#if alpha_TARGET_ARCH
-pprAddr (AddrReg r) = uppParens (pprReg r)
+pprAddr (AddrReg r) = parens (pprReg r)
pprAddr (AddrImm i) = pprImm i
pprAddr (AddrRegImm r1 i)
- = uppBeside (pprImm i) (uppParens (pprReg r1))
+ = (<>) (pprImm i) (parens (pprReg r1))
#endif
-------------------
@@ -334,23 +357,23 @@ pprAddr (ImmAddr imm off)
if (off == 0) then
pp_imm
else if (off < 0) then
- uppBeside pp_imm (uppInt off)
+ (<>) pp_imm (int off)
else
- uppBesides [pp_imm, uppChar '+', uppInt off]
+ hcat [pp_imm, char '+', int off]
pprAddr (Addr base index displacement)
= let
pp_disp = ppr_disp displacement
- pp_off p = uppBeside pp_disp (uppParens p)
+ pp_off p = (<>) pp_disp (parens p)
pp_reg r = pprReg L r
in
case (base,index) of
(Nothing, Nothing) -> pp_disp
(Just b, Nothing) -> pp_off (pp_reg b)
- (Nothing, Just (r,i)) -> pp_off (uppBesides [pp_reg r, uppComma, uppInt i])
- (Just b, Just (r,i)) -> pp_off (uppBesides [pp_reg b, uppComma, pp_reg r, uppComma, uppInt i])
+ (Nothing, Just (r,i)) -> pp_off (hcat [pp_reg r, comma, int i])
+ (Just b, Just (r,i)) -> pp_off (hcat [pp_reg b, comma, pp_reg r, comma, int i])
where
- ppr_disp (ImmInt 0) = uppNil
+ ppr_disp (ImmInt 0) = empty
ppr_disp imm = pprImm imm
#endif
@@ -360,24 +383,24 @@ pprAddr (Addr base index displacement)
pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
pprAddr (AddrRegReg r1 r2)
- = uppBesides [ pprReg r1, uppChar '+', pprReg r2 ]
+ = hcat [ pprReg r1, char '+', pprReg r2 ]
pprAddr (AddrRegImm r1 (ImmInt i))
| i == 0 = pprReg r1
| not (fits13Bits i) = largeOffsetError i
- | otherwise = uppBesides [ pprReg r1, pp_sign, uppInt i ]
+ | otherwise = hcat [ pprReg r1, pp_sign, int i ]
where
- pp_sign = if i > 0 then uppChar '+' else uppNil
+ pp_sign = if i > 0 then char '+' else empty
pprAddr (AddrRegImm r1 (ImmInteger i))
| i == 0 = pprReg r1
| not (fits13Bits i) = largeOffsetError i
- | otherwise = uppBesides [ pprReg r1, pp_sign, uppInteger i ]
+ | otherwise = hcat [ pprReg r1, pp_sign, integer i ]
where
- pp_sign = if i > 0 then uppChar '+' else uppNil
+ pp_sign = if i > 0 then char '+' else empty
pprAddr (AddrRegImm r1 imm)
- = uppBesides [ pprReg r1, uppChar '+', pprImm imm ]
+ = hcat [ pprReg r1, char '+', pprImm imm ]
#endif
\end{code}
@@ -388,22 +411,22 @@ pprAddr (AddrRegImm r1 imm)
%************************************************************************
\begin{code}
-pprInstr :: Instr -> Unpretty
+pprInstr :: Instr -> Doc
-pprInstr (COMMENT s) = uppNil -- nuke 'em
---alpha: = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s)
---i386 : = uppBeside (uppPStr SLIT("# ")) (uppPStr s)
---sparc: = uppBeside (uppPStr SLIT("! ")) (uppPStr s)
+pprInstr (COMMENT s) = empty -- nuke 'em
+--alpha: = (<>) (ptext SLIT("\t# ")) (ptext s)
+--i386 : = (<>) (ptext SLIT("# ")) (ptext s)
+--sparc: = (<>) (ptext SLIT("! ")) (ptext s)
pprInstr (SEGMENT TextSegment)
- = uppPStr
+ = ptext
IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
- = uppPStr
+ = ptext
IF_ARCH_alpha(SLIT("\t.data\n\t.align 3")
,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -}
,IF_ARCH_i386(SLIT(".data\n\t.align 2")
@@ -413,41 +436,40 @@ pprInstr (LABEL clab)
= let
pp_lab = pprCLabel_asm clab
in
- uppBesides [
+ hcat [
if not (externallyVisibleCLabel clab) then
- uppNil
+ empty
else
- uppBesides [uppPStr
+ hcat [ptext
IF_ARCH_alpha(SLIT("\t.globl\t")
,IF_ARCH_i386(SLIT(".globl ")
,IF_ARCH_sparc(SLIT("\t.global\t")
,)))
- , pp_lab, uppChar '\n'],
+ , pp_lab, char '\n'],
pp_lab,
- uppChar ':'
+ char ':'
]
pprInstr (ASCII False{-no backslash conversion-} str)
- = uppBesides [ uppPStr SLIT("\t.asciz "), uppChar '\"', uppStr str, uppChar '"' ]
+ = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ]
pprInstr (ASCII True str)
- = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
+ = (<>) (text "\t.ascii \"") (asciify str 60)
where
- asciify :: String -> Int -> Unpretty
-
- asciify [] _ = uppStr "\\0\""
- asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
- asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
- asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
- asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
- asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
+ asciify :: String -> Int -> Doc
+
+ asciify [] _ = text "\\0\""
+ asciify s n | n <= 0 = (<>) (text "\"\n\t.ascii \"") (asciify s 60)
+ asciify ('\\':cs) n = (<>) (text "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = (<>) (text "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = (<>) (char c) (asciify cs (n-1))
+ asciify [c] _ = (<>) (text (charToC c)) (text ("\\0\""))
asciify (c:(cs@(d:_))) n
- | isDigit d = uppBeside (uppStr (charToC c)) (asciify cs 0)
- | otherwise = uppBeside (uppStr (charToC c)) (asciify cs (n-1))
+ | isDigit d = (<>) (text (charToC c)) (asciify cs 0)
+ | otherwise = (<>) (text (charToC c)) (asciify cs (n-1))
pprInstr (DATA s xs)
- = uppInterleave (uppChar '\n')
- [uppBeside (uppPStr pp_size) (pprImm x) | x <- xs]
+ = vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs]
where
pp_size = case s of
#if alpha_TARGET_ARCH
@@ -491,177 +513,177 @@ pprInstr (DATA s xs)
#if alpha_TARGET_ARCH
pprInstr (LD size reg addr)
- = uppBesides [
- uppPStr SLIT("\tld"),
+ = hcat [
+ ptext SLIT("\tld"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDA reg addr)
- = uppBesides [
- uppPStr SLIT("\tlda\t"),
+ = hcat [
+ ptext SLIT("\tlda\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDAH reg addr)
- = uppBesides [
- uppPStr SLIT("\tldah\t"),
+ = hcat [
+ ptext SLIT("\tldah\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDGP reg addr)
- = uppBesides [
- uppPStr SLIT("\tldgp\t"),
+ = hcat [
+ ptext SLIT("\tldgp\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (LDI size reg imm)
- = uppBesides [
- uppPStr SLIT("\tldi"),
+ = hcat [
+ ptext SLIT("\tldi"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm imm
]
pprInstr (ST size reg addr)
- = uppBesides [
- uppPStr SLIT("\tst"),
+ = hcat [
+ ptext SLIT("\tst"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (CLR reg)
- = uppBesides [
- uppPStr SLIT("\tclr\t"),
+ = hcat [
+ ptext SLIT("\tclr\t"),
pprReg reg
]
pprInstr (ABS size ri reg)
- = uppBesides [
- uppPStr SLIT("\tabs"),
+ = hcat [
+ ptext SLIT("\tabs"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
pprInstr (NEG size ov ri reg)
- = uppBesides [
- uppPStr SLIT("\tneg"),
+ = hcat [
+ ptext SLIT("\tneg"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
pprInstr (ADD size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tadd"),
+ = hcat [
+ ptext SLIT("\tadd"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SADD size scale reg1 ri reg2)
- = uppBesides [
- uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
- uppPStr SLIT("add"),
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ ptext SLIT("add"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SUB size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tsub"),
+ = hcat [
+ ptext SLIT("\tsub"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (SSUB size scale reg1 ri reg2)
- = uppBesides [
- uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
- uppPStr SLIT("sub"),
+ = hcat [
+ ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}),
+ ptext SLIT("sub"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (MUL size ov reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tmul"),
+ = hcat [
+ ptext SLIT("\tmul"),
pprSize size,
- if ov then uppPStr SLIT("v\t") else uppChar '\t',
+ if ov then ptext SLIT("v\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (DIV size uns reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tdiv"),
+ = hcat [
+ ptext SLIT("\tdiv"),
pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ if uns then ptext SLIT("u\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (REM size uns reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\trem"),
+ = hcat [
+ ptext SLIT("\trem"),
pprSize size,
- if uns then uppPStr SLIT("u\t") else uppChar '\t',
+ if uns then ptext SLIT("u\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (NOT ri reg)
- = uppBesides [
- uppPStr SLIT("\tnot"),
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tnot"),
+ char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg
]
@@ -679,41 +701,41 @@ pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2
pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2
pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2
-pprInstr (NOP) = uppPStr SLIT("\tnop")
+pprInstr (NOP) = ptext SLIT("\tnop")
pprInstr (CMP cond reg1 ri reg2)
- = uppBesides [
- uppPStr SLIT("\tcmp"),
+ = hcat [
+ ptext SLIT("\tcmp"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FCLR reg)
- = uppBesides [
- uppPStr SLIT("\tfclr\t"),
+ = hcat [
+ ptext SLIT("\tfclr\t"),
pprReg reg
]
pprInstr (FABS reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tfabs\t"),
+ = hcat [
+ ptext SLIT("\tfabs\t"),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FNEG size reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tneg"),
+ = hcat [
+ ptext SLIT("\tneg"),
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
@@ -723,94 +745,94 @@ pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg
pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3
pprInstr (CVTxy size1 size2 reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tcvt"),
+ = hcat [
+ ptext SLIT("\tcvt"),
pprSize size1,
- case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2},
- uppChar '\t',
+ case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2},
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (FCMP size cond reg1 reg2 reg3)
- = uppBesides [
- uppPStr SLIT("\tcmp"),
+ = hcat [
+ ptext SLIT("\tcmp"),
pprSize size,
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
pprInstr (FMOV reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tfmov\t"),
+ = hcat [
+ ptext SLIT("\tfmov\t"),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-pprInstr (BI NEVER reg lab) = uppNil
+pprInstr (BI NEVER reg lab) = empty
pprInstr (BI cond reg lab)
- = uppBesides [
- uppPStr SLIT("\tb"),
+ = hcat [
+ ptext SLIT("\tb"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm lab
]
pprInstr (BF cond reg lab)
- = uppBesides [
- uppPStr SLIT("\tfb"),
+ = hcat [
+ ptext SLIT("\tfb"),
pprCond cond,
- uppChar '\t',
+ char '\t',
pprReg reg,
- uppComma,
+ comma,
pprImm lab
]
pprInstr (BR lab)
- = uppBeside (uppPStr SLIT("\tbr\t")) (pprImm lab)
+ = (<>) (ptext SLIT("\tbr\t")) (pprImm lab)
pprInstr (JMP reg addr hint)
- = uppBesides [
- uppPStr SLIT("\tjmp\t"),
+ = hcat [
+ ptext SLIT("\tjmp\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr,
- uppComma,
- uppInt hint
+ comma,
+ int hint
]
pprInstr (BSR imm n)
- = uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm imm)
+ = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm)
pprInstr (JSR reg addr n)
- = uppBesides [
- uppPStr SLIT("\tjsr\t"),
+ = hcat [
+ ptext SLIT("\tjsr\t"),
pprReg reg,
- uppComma,
+ comma,
pprAddr addr
]
pprInstr (FUNBEGIN clab)
- = uppBesides [
+ = hcat [
if (externallyVisibleCLabel clab) then
- uppBesides [uppPStr SLIT("\t.globl\t"), pp_lab, uppChar '\n']
+ hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n']
else
- uppNil,
- uppPStr SLIT("\t.ent "),
+ empty,
+ ptext SLIT("\t.ent "),
pp_lab,
- uppChar '\n',
+ char '\n',
pp_lab,
pp_ldgp,
pp_lab,
@@ -819,46 +841,46 @@ pprInstr (FUNBEGIN clab)
where
pp_lab = pprCLabel_asm clab
- pp_ldgp = uppPStr (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#))
- pp_frame = uppPStr (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
+ pp_ldgp = ptext (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#))
+ pp_frame = ptext (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#))
pprInstr (FUNEND clab)
- = uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
+ = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab)
\end{code}
Continue with Alpha-only printing bits and bobs:
\begin{code}
-pprRI :: RI -> Unpretty
+pprRI :: RI -> Doc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Unpretty
+pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc
pprRegRIReg name reg1 ri reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppChar '\t',
+ char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
@@ -876,7 +898,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3
pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack
| src == dst
- = uppPStr SLIT("")
+ = ptext SLIT("")
pprInstr (MOV size src dst)
= pprSizeOpOp SLIT("mov") size src dst
pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst
@@ -919,171 +941,171 @@ pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst
pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op
pprInstr (POP size op) = pprSizeOp SLIT("pop") size op
-pprInstr (NOP) = uppPStr SLIT("\tnop")
-pprInstr (CLTD) = uppPStr SLIT("\tcltd")
+pprInstr (NOP) = ptext SLIT("\tnop")
+pprInstr (CLTD) = ptext SLIT("\tcltd")
pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
-pprInstr (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm imm)
-pprInstr (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand L op)
+pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
+pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
pprInstr (CALL imm)
- = uppBesides [ uppPStr SLIT("\tcall "), pprImm imm ]
+ = hcat [ ptext SLIT("\tcall "), pprImm imm ]
-pprInstr SAHF = uppPStr SLIT("\tsahf")
-pprInstr FABS = uppPStr SLIT("\tfabs")
+pprInstr SAHF = ptext SLIT("\tsahf")
+pprInstr FABS = ptext SLIT("\tfabs")
pprInstr (FADD sz src@(OpAddr _))
- = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src]
pprInstr (FADD sz src)
- = uppPStr SLIT("\tfadd")
+ = ptext SLIT("\tfadd")
pprInstr FADDP
- = uppPStr SLIT("\tfaddp")
+ = ptext SLIT("\tfaddp")
pprInstr (FMUL sz src)
- = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src]
pprInstr FMULP
- = uppPStr SLIT("\tfmulp")
+ = ptext SLIT("\tfmulp")
pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
-pprInstr FCHS = uppPStr SLIT("\tfchs")
+pprInstr FCHS = ptext SLIT("\tfchs")
pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
-pprInstr FCOS = uppPStr SLIT("\tfcos")
+pprInstr FCOS = ptext SLIT("\tfcos")
pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
pprInstr (FDIV sz src)
- = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src]
pprInstr FDIVP
- = uppPStr SLIT("\tfdivp")
+ = ptext SLIT("\tfdivp")
pprInstr (FDIVR sz src)
- = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src]
pprInstr FDIVRP
- = uppPStr SLIT("\tfdivpr")
+ = ptext SLIT("\tfdivpr")
pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
pprInstr (FLD sz (OpImm (ImmCLbl src)))
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprCLabel_asm src]
+ = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src]
pprInstr (FLD sz src)
- = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprOperand sz src]
-pprInstr FLD1 = uppPStr SLIT("\tfld1")
-pprInstr FLDZ = uppPStr SLIT("\tfldz")
+ = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src]
+pprInstr FLD1 = ptext SLIT("\tfld1")
+pprInstr FLDZ = ptext SLIT("\tfldz")
pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
-pprInstr FRNDINT = uppPStr SLIT("\tfrndint")
-pprInstr FSIN = uppPStr SLIT("\tfsin")
-pprInstr FSQRT = uppPStr SLIT("\tfsqrt")
+pprInstr FRNDINT = ptext SLIT("\tfrndint")
+pprInstr FSIN = ptext SLIT("\tfsin")
+pprInstr FSQRT = ptext SLIT("\tfsqrt")
pprInstr (FST sz dst)
- = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppSP, pprOperand sz dst]
+ = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst]
pprInstr (FSTP sz dst)
- = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppSP, pprOperand sz dst]
+ = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst]
pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
pprInstr (FSUB sz src)
- = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppSP, pprOperand sz src]
+ = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src]
pprInstr FSUBP
- = uppPStr SLIT("\tfsubp")
+ = ptext SLIT("\tfsubp")
pprInstr (FSUBR size src)
= pprSizeOp SLIT("fsubr") size src
pprInstr FSUBRP
- = uppPStr SLIT("\tfsubpr")
+ = ptext SLIT("\tfsubpr")
pprInstr (FISUBR size op)
= pprSizeAddr SLIT("fisubr") size op
-pprInstr FTST = uppPStr SLIT("\tftst")
+pprInstr FTST = ptext SLIT("\tftst")
pprInstr (FCOMP sz op)
- = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppSP, pprOperand sz op]
-pprInstr FUCOMPP = uppPStr SLIT("\tfucompp")
-pprInstr FXCH = uppPStr SLIT("\tfxch")
-pprInstr FNSTSW = uppPStr SLIT("\tfnstsw %ax")
-pprInstr FNOP = uppPStr SLIT("")
+ = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op]
+pprInstr FUCOMPP = ptext SLIT("\tfucompp")
+pprInstr FXCH = ptext SLIT("\tfxch")
+pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax")
+pprInstr FNOP = ptext SLIT("")
\end{code}
Continue with I386-only printing bits and bobs:
\begin{code}
-pprDollImm :: Imm -> Unpretty
+pprDollImm :: Imm -> Doc
-pprDollImm i = uppBesides [ uppPStr SLIT("$"), pprImm i]
+pprDollImm i = hcat [ ptext SLIT("$"), pprImm i]
-pprOperand :: Size -> Operand -> Unpretty
+pprOperand :: Size -> Operand -> Doc
pprOperand s (OpReg r) = pprReg s r
pprOperand s (OpImm i) = pprDollImm i
pprOperand s (OpAddr ea) = pprAddr ea
-pprSizeOp :: FAST_STRING -> Size -> Operand -> Unpretty
+pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
pprSizeOp name size op1
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1
]
-pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
pprSizeOpOp name size op1 op2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1,
- uppComma,
+ comma,
pprOperand size op2
]
-pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Unpretty
+pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc
pprSizeOpReg name size op1 reg
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprOperand size op1,
- uppComma,
+ comma,
pprReg size reg
]
-pprSizeAddr :: FAST_STRING -> Size -> Addr -> Unpretty
+pprSizeAddr :: FAST_STRING -> Size -> Addr -> Doc
pprSizeAddr name size op
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Unpretty
+pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Doc
pprSizeAddrReg name size op dst
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
pprSize size,
- uppSP,
+ space,
pprAddr op,
- uppComma,
+ comma,
pprReg size dst
]
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
- = uppBesides [
- uppChar '\t',
- uppPStr name, uppSP,
+ = hcat [
+ char '\t',
+ ptext name, space,
pprOperand size op1,
- uppComma,
+ comma,
pprOperand size op2
]
-pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc
pprSizeOpOpCoerce name size1 size2 op1 op2
- = uppBesides [ uppChar '\t', uppPStr name, uppSP,
+ = hcat [ char '\t', ptext name, space,
pprOperand size1 op1,
- uppComma,
+ comma,
pprOperand size2 op2
]
-pprCondInstr :: FAST_STRING -> Cond -> Unpretty -> Unpretty
+pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc
pprCondInstr name cond arg
- = uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppSP, arg]
+ = hcat [ char '\t', ptext name, pprCond cond, space, arg]
#endif {-i386_TARGET_ARCH-}
\end{code}
@@ -1100,13 +1122,13 @@ pprCondInstr name cond arg
-- a clumsy hack for now, to handle possible double alignment problems
pprInstr (LD DF addr reg) | maybeToBool off_addr
- = uppBesides [
+ = hcat [
pp_ld_lbracket,
pprAddr addr,
pp_rbracket_comma,
pprReg reg,
- uppChar '\n',
+ char '\n',
pp_ld_lbracket,
pprAddr addr2,
pp_rbracket_comma,
@@ -1117,11 +1139,11 @@ pprInstr (LD DF addr reg) | maybeToBool off_addr
addr2 = case off_addr of Just x -> x
pprInstr (LD size addr reg)
- = uppBesides [
- uppPStr SLIT("\tld"),
+ = hcat [
+ ptext SLIT("\tld"),
pprSize size,
- uppChar '\t',
- uppLbrack,
+ char '\t',
+ lbrack,
pprAddr addr,
pp_rbracket_comma,
pprReg reg
@@ -1130,44 +1152,48 @@ pprInstr (LD size addr reg)
-- The same clumsy hack as above
pprInstr (ST DF reg addr) | maybeToBool off_addr
- = uppBesides [
- uppPStr SLIT("\tst\t"),
+ = hcat [
+ ptext SLIT("\tst\t"),
pprReg reg,
pp_comma_lbracket,
pprAddr addr,
- uppPStr SLIT("]\n\tst\t"),
+ ptext SLIT("]\n\tst\t"),
pprReg (fPair reg),
pp_comma_lbracket,
pprAddr addr2,
- uppRbrack
+ rbrack
]
where
off_addr = addrOffset addr 4
addr2 = case off_addr of Just x -> x
+-- no distinction is made between signed and unsigned bytes on stores for the
+-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
+-- so we call a special-purpose pprSize for ST..
+
pprInstr (ST size reg addr)
- = uppBesides [
- uppPStr SLIT("\tst"),
- pprSize size,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tst"),
+ pprStSize size,
+ char '\t',
pprReg reg,
pp_comma_lbracket,
pprAddr addr,
- uppRbrack
+ rbrack
]
pprInstr (ADD x cc reg1 ri reg2)
| not x && not cc && riZero ri
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
pprInstr (SUB x cc reg1 ri reg2)
| not x && cc && reg2 == g0
- = uppBesides [ uppPStr SLIT("\tcmp\t"), pprReg reg1, uppComma, pprRI ri ]
+ = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ]
| not x && not cc && riZero ri
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
@@ -1176,7 +1202,7 @@ pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2
pprInstr (OR b reg1 ri reg2)
| not b && reg1 == g0
- = uppBesides [ uppPStr SLIT("\tmov\t"), pprRI ri, uppComma, pprReg reg2 ]
+ = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ]
| otherwise
= pprRegRIReg SLIT("or") b reg1 ri reg2
@@ -1190,20 +1216,20 @@ pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2
pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2
pprInstr (SETHI imm reg)
- = uppBesides [
- uppPStr SLIT("\tsethi\t"),
+ = hcat [
+ ptext SLIT("\tsethi\t"),
pprImm imm,
- uppComma,
+ comma,
pprReg reg
]
-pprInstr NOP = uppPStr SLIT("\tnop")
+pprInstr NOP = ptext SLIT("\tnop")
pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
pprInstr (FABS DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FADD size reg1 reg2 reg3)
@@ -1215,9 +1241,9 @@ pprInstr (FDIV size reg1 reg2 reg3)
pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
pprInstr (FMOV DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FMUL size reg1 reg2 reg3)
@@ -1225,114 +1251,114 @@ pprInstr (FMUL size reg1 reg2 reg3)
pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
pprInstr (FNEG DF reg1 reg2)
- = uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
- (if (reg1 == reg2) then uppNil
- else uppBeside (uppChar '\n')
+ = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2)
+ (if (reg1 == reg2) then empty
+ else (<>) (char '\n')
(pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
pprInstr (FxTOy size1 size2 reg1 reg2)
- = uppBesides [
- uppPStr SLIT("\tf"),
- uppPStr
+ = hcat [
+ ptext SLIT("\tf"),
+ ptext
(case size1 of
W -> SLIT("ito")
F -> SLIT("sto")
DF -> SLIT("dto")),
- uppPStr
+ ptext
(case size2 of
W -> SLIT("i\t")
F -> SLIT("s\t")
DF -> SLIT("d\t")),
- pprReg reg1, uppComma, pprReg reg2
+ pprReg reg1, comma, pprReg reg2
]
pprInstr (BI cond b lab)
- = uppBesides [
- uppPStr SLIT("\tb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
pprImm lab
]
pprInstr (BF cond b lab)
- = uppBesides [
- uppPStr SLIT("\tfb"), pprCond cond,
- if b then pp_comma_a else uppNil,
- uppChar '\t',
+ = hcat [
+ ptext SLIT("\tfb"), pprCond cond,
+ if b then pp_comma_a else empty,
+ char '\t',
pprImm lab
]
-pprInstr (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr addr)
+pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr)
pprInstr (CALL imm n _)
- = uppBesides [ uppPStr SLIT("\tcall\t"), pprImm imm, uppComma, uppInt n ]
+ = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ]
\end{code}
Continue with SPARC-only printing bits and bobs:
\begin{code}
-pprRI :: RI -> Unpretty
+pprRI :: RI -> Doc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
pprSizeRegReg name size reg1 reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
(case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
+ F -> ptext SLIT("s\t")
+ DF -> ptext SLIT("d\t")),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2
]
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
- = uppBesides [
- uppChar '\t',
- uppPStr name,
+ = hcat [
+ char '\t',
+ ptext name,
(case size of
- F -> uppPStr SLIT("s\t")
- DF -> uppPStr SLIT("d\t")),
+ F -> ptext SLIT("s\t")
+ DF -> ptext SLIT("d\t")),
pprReg reg1,
- uppComma,
+ comma,
pprReg reg2,
- uppComma,
+ comma,
pprReg reg3
]
-pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
+pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc
pprRegRIReg name b reg1 ri reg2
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext SLIT("cc\t") else char '\t',
pprReg reg1,
- uppComma,
+ comma,
pprRI ri,
- uppComma,
+ comma,
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Unpretty
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
pprRIReg name b ri reg1
- = uppBesides [
- uppChar '\t',
- uppPStr name,
- if b then uppPStr SLIT("cc\t") else uppChar '\t',
+ = hcat [
+ char '\t',
+ ptext name,
+ if b then ptext SLIT("cc\t") else char '\t',
pprRI ri,
- uppComma,
+ comma,
pprReg reg1
]
-pp_ld_lbracket = uppPStr (pACK_STR (a_HASH "\tld\t["#))
-pp_rbracket_comma = uppPStr (pACK_STR (a_HASH "],"#))
-pp_comma_lbracket = uppPStr (pACK_STR (a_HASH ",["#))
-pp_comma_a = uppPStr (pACK_STR (a_HASH ",a"#))
+pp_ld_lbracket = ptext (pACK_STR (a_HASH "\tld\t["#))
+pp_rbracket_comma = ptext (pACK_STR (a_HASH "],"#))
+pp_comma_lbracket = ptext (pACK_STR (a_HASH ",["#))
+pp_comma_a = ptext (pACK_STR (a_HASH ",a"#))
#endif {-sparc_TARGET_ARCH-}
\end{code}
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 22a7618e54..be0d40d039 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -51,7 +51,15 @@ module RegAllocInfo (
freeRegSet
) where
+#if __GLASGOW_HASKELL__ >= 202
+import qualified GlaExts (Addr(..))
+import GlaExts hiding (Addr(..))
+import FastString
+import Ubiq
+#else
IMP_Ubiq(){-uitous-}
+import Pretty ( Doc )
+#endif
IMPORT_1_3(List(partition))
import MachMisc
@@ -66,7 +74,6 @@ import OrdList ( mkUnitList, OrdList )
import PrimRep ( PrimRep(..) )
import Stix ( StixTree, CodeSegment )
import UniqSet -- quite a bit of it
-import Unpretty ( uppShow )
\end{code}
%************************************************************************
@@ -533,7 +540,7 @@ regLiveness instr info@(RL live future@(FL all env))
lookup lbl
= case (lookupFM env lbl) of
Just rs -> rs
- Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel_asm lbl)) ++
+ Nothing -> trace ("Missing " ++ (show (pprCLabel_asm lbl)) ++
" in future?") emptyRegSet
in
case instr of -- the rest is machine-specific...
diff --git a/ghc/compiler/nativeGen/Stix.hi-boot b/ghc/compiler/nativeGen/Stix.hi-boot
new file mode 100644
index 0000000000..76cfdab112
--- /dev/null
+++ b/ghc/compiler/nativeGen/Stix.hi-boot
@@ -0,0 +1,5 @@
+_interface_ Stix 1
+_exports_
+Stix StixTree;
+_declarations_
+1 data StixTree;
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 10521a3d68..1dbd660615 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -20,9 +20,12 @@ IMPORT_1_3(Ratio(Rational))
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
-import CLabel ( mkAsmTempLabel )
+import CLabel ( mkAsmTempLabel, CLabel )
+import PrimRep ( PrimRep )
+import PrimOp ( PrimOp )
+import Unique ( Unique )
import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) )
-import Unpretty ( uppPStr, SYN_IE(Unpretty) )
+import Pretty ( ptext, Doc )
\end{code}
Here is the tag at the nodes of our @StixTree@. Notice its
@@ -39,7 +42,7 @@ data StixTree
| StInt Integer -- ** add Kind at some point
| StDouble Rational
| StString FAST_STRING
- | StLitLbl Unpretty -- literal labels
+ | StLitLbl Doc -- literal labels
-- (will be _-prefixed on some machines)
| StLitLit FAST_STRING -- innards from CLitLit
| StCLbl CLabel -- labels that we might index into
@@ -100,7 +103,7 @@ data StixTree
| StComment FAST_STRING
sStLitLbl :: FAST_STRING -> StixTree
-sStLitLbl s = StLitLbl (uppPStr s)
+sStLitLbl s = StLitLbl (ptext s)
\end{code}
Stix registers can have two forms. They {\em may} or {\em may not}
diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index 150dc41a9c..56daf99c6c 100644
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -26,7 +26,7 @@ import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
import Stix -- all of it
import StixPrim ( amodeToStix )
import UniqSupply ( returnUs, SYN_IE(UniqSM) )
-import Unpretty ( uppBesides, uppPStr, uppInt, uppChar )
+import Pretty ( hcat, ptext, int, char )
\end{code}
Generating code for info tables (arrays of data).
@@ -79,21 +79,21 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _)
tag]
SpecialisedRep _ _ _ updatable ->
- let rtbl = uppBesides (
+ let rtbl = hcat (
if is_selector then
- [uppPStr SLIT("Select__"),
- uppInt select_word,
- uppPStr SLIT("_rtbl")]
+ [ptext SLIT("Select__"),
+ int select_word,
+ ptext SLIT("_rtbl")]
else
- [uppPStr (case updatable of
+ [ptext (case updatable of
SMNormalForm -> SLIT("Spec_N_")
SMSingleEntry -> SLIT("Spec_S_")
SMUpdatable -> SLIT("Spec_U_")
),
- uppInt size,
- uppChar '_',
- uppInt ptrs,
- uppPStr SLIT("_rtbl")])
+ int size,
+ char '_',
+ int ptrs,
+ ptext SLIT("_rtbl")])
in
case updatable of
SMNormalForm -> [upd_code, StLitLbl rtbl, tag]
diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 45e11d8349..d4be4d50d1 100644
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -15,7 +15,11 @@ IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn -- bits and bobs...
import Constants ( mIN_MP_INT_SIZE )
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 664b2df9fb..5333c3c70e 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -11,7 +11,11 @@ IMP_Ubiq(){-uitious-}
IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
diff --git a/ghc/compiler/nativeGen/StixPrim.hi-boot b/ghc/compiler/nativeGen/StixPrim.hi-boot
new file mode 100644
index 0000000000..1df7a8c364
--- /dev/null
+++ b/ghc/compiler/nativeGen/StixPrim.hi-boot
@@ -0,0 +1,5 @@
+_interface_ StixPrim 1
+_exports_
+StixPrim amodeToStix;
+_declarations_
+1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixTree ;;
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 14bc255828..ad04c1d1d9 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -11,7 +11,11 @@ IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
import MachMisc
+#if __GLASGOW_HASKELL__ >= 202
+import MachRegs hiding (Addr)
+#else
import MachRegs
+#endif
import AbsCSyn
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
@@ -30,7 +34,7 @@ import Stix
import StixMacro ( heapCheck )
import StixInteger {- everything -}
import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
-import Unpretty ( uppBeside, uppPStr, uppInt )
+import Pretty ( (<>), ptext, int )
import Util ( panic )
#ifdef REALLY_HASKELL_1_3
@@ -233,7 +237,7 @@ primCode [lhs] ReadArrayOp [obj, ix]
in
returnUs (\xs -> assign : xs)
-primCode [lhs] WriteArrayOp [obj, ix, v]
+primCode [] WriteArrayOp [obj, ix, v]
= let
obj' = amodeToStix obj
ix' = amodeToStix ix
@@ -469,7 +473,7 @@ simplePrim [lhs] op rest
ReturnsPrim pk -> pk
_ -> simplePrim_error op
-simplePrim _ op _ = simplePrim_error op
+simplePrim as op bs = simplePrim_error op
simplePrim_error op
= error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
@@ -523,7 +527,7 @@ amodeToStix (CTableEntry base off pk)
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
- = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
where
off = charLikeSize * ord c
View Lorry Controller Status