diff --git a/0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch b/0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch deleted file mode 100644 index 392143a..0000000 --- a/0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch +++ /dev/null @@ -1,71 +0,0 @@ -From 4f52849a99753fab63d634769dd35a31f4d5a1b2 Mon Sep 17 00:00:00 2001 -From: Herbert Valerio Riedel -Date: Thu, 12 May 2016 20:36:34 +0200 -Subject: [PATCH] Fix misspelled WORDS_BIGENDIAN macro - -This was causing word{16,32,64}{le,be} primitives to break -on big endian archs (such as `powerpc`/`powerpc64`) with -serious consequences such as -https://github.com/TomMD/pureMD5/issues/5 ---- - Data/ByteString/Builder/Prim/Binary.hs | 12 ++++++------ - 1 file changed, 6 insertions(+), 6 deletions(-) - -Index: ghc-8.0.1/libraries/bytestring/Data/ByteString/Builder/Prim/Binary.hs -=================================================================== ---- ghc-8.0.1.orig/libraries/bytestring/Data/ByteString/Builder/Prim/Binary.hs -+++ ghc-8.0.1/libraries/bytestring/Data/ByteString/Builder/Prim/Binary.hs -@@ -83,7 +83,7 @@ word8 = storableToF - -- | Encoding 'Word16's in big endian format. - {-# INLINE word16BE #-} - word16BE :: FixedPrim Word16 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - word16BE = word16Host - #else - word16BE = fixedPrim 2 $ \w p -> do -@@ -94,7 +94,7 @@ word16BE = fixedPrim 2 $ \w p -> do - -- | Encoding 'Word16's in little endian format. - {-# INLINE word16LE #-} - word16LE :: FixedPrim Word16 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - word16LE = fixedPrim 2 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) -@@ -105,7 +105,7 @@ word16LE = word16Host - -- | Encoding 'Word32's in big endian format. - {-# INLINE word32BE #-} - word32BE :: FixedPrim Word32 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - word32BE = word32Host - #else - word32BE = fixedPrim 4 $ \w p -> do -@@ -118,7 +118,7 @@ word32BE = fixedPrim 4 $ \w p -> do - -- | Encoding 'Word32's in little endian format. - {-# INLINE word32LE #-} - word32LE :: FixedPrim Word32 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - word32LE = fixedPrim 4 $ \w p -> do - poke p (fromIntegral (w) :: Word8) - poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) -@@ -134,7 +134,7 @@ word32LE = word32Host - -- | Encoding 'Word64's in big endian format. - {-# INLINE word64BE #-} - word64BE :: FixedPrim Word64 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - word64BE = word64Host - #else - #if WORD_SIZE_IN_BITS < 64 -@@ -170,7 +170,7 @@ word64BE = fixedPrim 8 $ \w p -> do - -- | Encoding 'Word64's in little endian format. - {-# INLINE word64LE #-} - word64LE :: FixedPrim Word64 --#ifdef WORD_BIGENDIAN -+#ifdef WORDS_BIGENDIAN - #if WORD_SIZE_IN_BITS < 64 - word64LE = - fixedPrim 8 $ \w p -> do diff --git a/0001-PPC-CodeGen-fix-lwa-instruction-generation.patch b/0001-PPC-CodeGen-fix-lwa-instruction-generation.patch index 0858cfe..ffe83af 100644 --- a/0001-PPC-CodeGen-fix-lwa-instruction-generation.patch +++ b/0001-PPC-CodeGen-fix-lwa-instruction-generation.patch @@ -7,11 +7,11 @@ Subject: [PATCH] PPC/CodeGen: fix lwa instruction generation compiler/nativeGen/PPC/CodeGen.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) -Index: ghc-7.10.3/compiler/nativeGen/PPC/CodeGen.hs +Index: ghc-8.0.1/compiler/nativeGen/PPC/CodeGen.hs =================================================================== ---- ghc-7.10.3.orig/compiler/nativeGen/PPC/CodeGen.hs -+++ ghc-7.10.3/compiler/nativeGen/PPC/CodeGen.hs -@@ -464,7 +464,7 @@ getRegister' _ (CmmMachOp (MO_UU_Conv W3 +--- ghc-8.0.1.orig/compiler/nativeGen/PPC/CodeGen.hs ++++ ghc-8.0.1/compiler/nativeGen/PPC/CodeGen.hs +@@ -471,7 +471,7 @@ getRegister' _ (CmmMachOp (MO_UU_Conv W3 return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do diff --git a/0001-StgCmmPrim-Add-missing-write-barrier.patch b/0001-StgCmmPrim-Add-missing-write-barrier.patch index da62d8d..0cd0b77 100644 --- a/0001-StgCmmPrim-Add-missing-write-barrier.patch +++ b/0001-StgCmmPrim-Add-missing-write-barrier.patch @@ -7,11 +7,11 @@ Subject: [PATCH] StgCmmPrim: Add missing write barrier. compiler/codeGen/StgCmmPrim.hs | 1 + 1 file changed, 1 insertion(+) -Index: ghc-7.10.3/compiler/codeGen/StgCmmPrim.hs +Index: ghc-8.0.1/compiler/codeGen/StgCmmPrim.hs =================================================================== ---- ghc-7.10.3.orig/compiler/codeGen/StgCmmPrim.hs -+++ ghc-7.10.3/compiler/codeGen/StgCmmPrim.hs -@@ -1324,6 +1324,7 @@ doWritePtrArrayOp addr idx val +--- ghc-8.0.1.orig/compiler/codeGen/StgCmmPrim.hs ++++ ghc-8.0.1/compiler/codeGen/StgCmmPrim.hs +@@ -1353,6 +1353,7 @@ doWritePtrArrayOp addr idx val emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] diff --git a/0001-implement-native-code-generator-for-ppc64.patch b/0001-implement-native-code-generator-for-ppc64.patch deleted file mode 100644 index 2eff943..0000000 --- a/0001-implement-native-code-generator-for-ppc64.patch +++ /dev/null @@ -1,2520 +0,0 @@ -Index: ghc-7.10.2.20151114/aclocal.m4 -=================================================================== ---- ghc-7.10.2.20151114.orig/aclocal.m4 -+++ ghc-7.10.2.20151114/aclocal.m4 -@@ -188,7 +188,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_V - test -z "[$]2" || eval "[$]2=ArchPPC" - ;; - powerpc64) -- test -z "[$]2" || eval "[$]2=ArchPPC_64" -+ test -z "[$]2" || eval "[$]2=\"ArchPPC_64 {ppc_64ABI = ELF_V1}\"" -+ ;; -+ powerpc64le) -+ test -z "[$]2" || eval "[$]2=\"ArchPPC_64 {ppc_64ABI = ELF_V2}\"" - ;; - sparc) - test -z "[$]2" || eval "[$]2=ArchSPARC" -@@ -209,7 +212,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_V - mipsel) - test -z "[$]2" || eval "[$]2=ArchMipsel" - ;; -- hppa|hppa1_1|ia64|m68k|powerpc64le|rs6000|s390|s390x|sparc64|vax) -+ hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax) - test -z "[$]2" || eval "[$]2=ArchUnknown" - ;; - *) -Index: ghc-7.10.2.20151114/compiler/cmm/CLabel.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/cmm/CLabel.hs -+++ ghc-7.10.2.20151114/compiler/cmm/CLabel.hs -@@ -1186,16 +1186,24 @@ pprDynamicLinkerAsmLabel platform dllInf - else if osElfTarget (platformOS platform) - then if platformArch platform == ArchPPC - then case dllInfo of -- CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] -- ppr lbl <> text "+32768@plt" -- SymbolPtr -> text ".LC_" <> ppr lbl -- _ -> panic "pprDynamicLinkerAsmLabel" -+ CodeStub -> -- See Note [.LCTOC1 in PPC PIC code] -+ ppr lbl <> text "+32768@plt" -+ SymbolPtr -> text ".LC_" <> ppr lbl -+ _ -> panic "pprDynamicLinkerAsmLabel" - else if platformArch platform == ArchX86_64 - then case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - GotSymbolPtr -> ppr lbl <> text "@gotpcrel" - GotSymbolOffset -> ppr lbl - SymbolPtr -> text ".LC_" <> ppr lbl -+ else if platformArch platform == ArchPPC_64 ELF_V1 -+ || platformArch platform == ArchPPC_64 ELF_V2 -+ then case dllInfo of -+ GotSymbolPtr -> text ".LC_" <> ppr lbl -+ <> text "@toc" -+ GotSymbolOffset -> ppr lbl -+ SymbolPtr -> text ".LC_" <> ppr lbl -+ _ -> panic "pprDynamicLinkerAsmLabel" - else case dllInfo of - CodeStub -> ppr lbl <> text "@plt" - SymbolPtr -> text ".LC_" <> ppr lbl -Index: ghc-7.10.2.20151114/compiler/codeGen/CodeGen/Platform.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/codeGen/CodeGen/Platform.hs -+++ ghc-7.10.2.20151114/compiler/codeGen/CodeGen/Platform.hs -@@ -31,7 +31,7 @@ callerSaves platform - ArchARM {} -> ARM.callerSaves - ArchARM64 -> ARM64.callerSaves - arch -- | arch `elem` [ArchPPC, ArchPPC_64] -> -+ | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.callerSaves - _ -> PPC.callerSaves -@@ -54,7 +54,7 @@ activeStgRegs platform - ArchARM {} -> ARM.activeStgRegs - ArchARM64 -> ARM64.activeStgRegs - arch -- | arch `elem` [ArchPPC, ArchPPC_64] -> -+ | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.activeStgRegs - _ -> PPC.activeStgRegs -@@ -72,7 +72,7 @@ haveRegBase platform - ArchARM {} -> ARM.haveRegBase - ArchARM64 -> ARM64.haveRegBase - arch -- | arch `elem` [ArchPPC, ArchPPC_64] -> -+ | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.haveRegBase - _ -> PPC.haveRegBase -@@ -90,7 +90,7 @@ globalRegMaybe platform - ArchARM {} -> ARM.globalRegMaybe - ArchARM64 -> ARM64.globalRegMaybe - arch -- | arch `elem` [ArchPPC, ArchPPC_64] -> -+ | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.globalRegMaybe - _ -> PPC.globalRegMaybe -@@ -108,7 +108,7 @@ freeReg platform - ArchARM {} -> ARM.freeReg - ArchARM64 -> ARM64.freeReg - arch -- | arch `elem` [ArchPPC, ArchPPC_64] -> -+ | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> - case platformOS platform of - OSDarwin -> PPC_Darwin.freeReg - _ -> PPC.freeReg -Index: ghc-7.10.2.20151114/compiler/nativeGen/AsmCodeGen.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/AsmCodeGen.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/AsmCodeGen.hs -@@ -167,18 +167,18 @@ nativeCodeGen dflags this_mod modLoc h u - => NcgImpl statics instr jumpDest -> IO UniqSupply - nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms - in case platformArch platform of -- ArchX86 -> nCG' (x86NcgImpl dflags) -- ArchX86_64 -> nCG' (x86_64NcgImpl dflags) -- ArchPPC -> nCG' (ppcNcgImpl dflags) -- ArchSPARC -> nCG' (sparcNcgImpl dflags) -- ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" -- ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" -- ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" -- ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" -- ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" -- ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" -- ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -- ArchJavaScript -> panic "nativeCodeGen: No NCG for JavaScript" -+ ArchX86 -> nCG' (x86NcgImpl dflags) -+ ArchX86_64 -> nCG' (x86_64NcgImpl dflags) -+ ArchPPC -> nCG' (ppcNcgImpl dflags) -+ ArchSPARC -> nCG' (sparcNcgImpl dflags) -+ ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" -+ ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64" -+ ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags) -+ ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha" -+ ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb" -+ ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel" -+ ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -+ ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" - - x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics) X86.Instr.Instr X86.Instr.JumpDest - x86NcgImpl dflags -Index: ghc-7.10.2.20151114/compiler/nativeGen/PIC.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/PIC.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/PIC.hs -@@ -158,7 +158,14 @@ cmmMakePicReference dflags lbl - -- everything gets relocated at runtime - | OSMinGW32 <- platformOS $ targetPlatform dflags - = CmmLit $ CmmLabel lbl -- -+ -- both ABI versions default to medium code model -+ | ArchPPC_64 _ <- platformArch $ targetPlatform dflags -+ = CmmMachOp (MO_Add W32) -- code model medium -+ [ CmmReg (CmmGlobal PicBaseReg) -+ , CmmLit $ picRelative -+ (platformArch $ targetPlatform dflags) -+ (platformOS $ targetPlatform dflags) -+ lbl ] - - | (gopt Opt_PIC dflags || not (gopt Opt_Static dflags)) && absoluteLabel lbl - = CmmMachOp (MO_Add (wordWidth dflags)) -@@ -293,13 +300,17 @@ howToAccessLabel dflags arch OSDarwin th - -- from position independent code. It is also required from the main program - -- when dynamic libraries containing Haskell code are used. - --howToAccessLabel _ ArchPPC_64 os _ kind _ -+howToAccessLabel _ (ArchPPC_64 _) os _ kind _ - | osElfTarget os -- = if kind == DataReference -- -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC -- then AccessViaSymbolPtr -- -- actually, .label instead of label -- else AccessDirectly -+ = case kind of -+ -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC -+ DataReference -> AccessViaSymbolPtr -+ -- RTLD does not generate stubs for function descriptors -+ -- in tail calls. Create a symbol pointer and generate -+ -- the code to load the function descriptor at the call site. -+ JumpReference -> AccessViaSymbolPtr -+ -- regular calls are handled by the runtime linker -+ _ -> AccessDirectly - - howToAccessLabel dflags _ os _ _ _ - -- no PIC -> the dynamic linker does everything for us; -@@ -430,9 +441,14 @@ needImportedSymbols dflags arch os - , arch == ArchPPC - = gopt Opt_PIC dflags || not (gopt Opt_Static dflags) - -+ -- PowerPC 64 Linux: always -+ | osElfTarget os -+ , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2 -+ = True -+ - -- i386 (and others?): -dynamic but not -fPIC - | osElfTarget os -- , arch /= ArchPPC_64 -+ , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = not (gopt Opt_Static dflags) && not (gopt Opt_PIC dflags) - - | otherwise -@@ -467,16 +483,30 @@ pprGotDeclaration dflags ArchX86 OSDarwi - pprGotDeclaration _ _ OSDarwin - = empty - -+-- PPC 64 ELF v1needs a Table Of Contents (TOC) on Linux -+pprGotDeclaration _ (ArchPPC_64 ELF_V1) OSLinux -+ = ptext (sLit ".section \".toc\",\"aw\"") -+-- In ELF v2 we also need to tell the assembler that we want ABI -+-- version 2. This would normally be done at the top of the file -+-- right after a file directive, but I could not figure out how -+-- to do that. -+pprGotDeclaration _ (ArchPPC_64 ELF_V2) OSLinux -+ = vcat [ ptext (sLit ".abiversion 2"), -+ ptext (sLit ".section \".toc\",\"aw\"") -+ ] -+pprGotDeclaration _ (ArchPPC_64 _) _ -+ = panic "pprGotDeclaration: ArchPPC_64 only Linux supported" -+ - -- Emit GOT declaration - -- Output whatever needs to be output once per .s file. - pprGotDeclaration dflags arch os - | osElfTarget os -- , arch /= ArchPPC_64 -+ , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - , not (gopt Opt_PIC dflags) - = empty - - | osElfTarget os -- , arch /= ArchPPC_64 -+ , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = vcat [ - -- See Note [.LCTOC1 in PPC PIC code] - ptext (sLit ".section \".got2\",\"aw\""), -@@ -635,9 +665,16 @@ pprImportedSymbol _ (Platform { platform - -- the NCG will keep track of all DynamicLinkerLabels it uses - -- and output each of them using pprImportedSymbol. - --pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 }) _ -+pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) -+ importedLbl - | osElfTarget (platformOS platform) -- = empty -+ = case dynamicLinkerLabelInfo importedLbl of -+ Just (SymbolPtr, lbl) -+ -> vcat [ -+ ptext (sLit ".section \".toc\", \"aw\""), -+ ptext (sLit ".LC_") <> pprCLabel platform lbl <> char ':', -+ ptext (sLit "\t.quad") <+> pprCLabel platform lbl ] -+ _ -> empty - - pprImportedSymbol dflags platform importedLbl - | osElfTarget (platformOS platform) -@@ -735,6 +772,28 @@ initializePicBase_ppc ArchPPC OSDarwin p - where BasicBlock bID insns = entry - b' = BasicBlock bID (PPC.FETCHPC picReg : insns) - -+------------------------------------------------------------------------- -+-- Load TOC into register 2 -+-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee -+-- in register 12. -+-- We pass the label to FETCHTOC and create a .localentry too. -+-- TODO: Explain this better and refer to ABI spec! -+{- -+We would like to do approximately this, but spill slot allocation -+might be added before the first BasicBlock. That violates the ABI. -+ -+For now we will emit the prologue code in the pretty printer, -+which is also what we do for ELF v1. -+initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg -+ (CmmProc info lab live (ListGraph (entry:blocks)) : statics) -+ = do -+ bID <-getUniqueM -+ return (CmmProc info lab live (ListGraph (b':entry:blocks)) -+ : statics) -+ where BasicBlock entryID _ = entry -+ b' = BasicBlock bID [PPC.FETCHTOC picReg lab, -+ PPC.BCC PPC.ALWAYS entryID] -+-} - - initializePicBase_ppc _ _ _ _ - = panic "initializePicBase_ppc: not needed" -Index: ghc-7.10.2.20151114/compiler/nativeGen/PPC/CodeGen.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/PPC/CodeGen.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/PPC/CodeGen.hs -@@ -77,14 +77,24 @@ cmmTopCodeGen - cmmTopCodeGen (CmmProc info lab live graph) = do - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks -- picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlags - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - os = platformOS $ targetPlatform dflags -- case picBaseMb of -- Just picBase -> initializePicBase_ppc ArchPPC os picBase tops -- Nothing -> return tops -+ arch = platformArch $ targetPlatform dflags -+ case arch of -+ ArchPPC -> do -+ picBaseMb <- getPicBaseMaybeNat -+ case picBaseMb of -+ Just picBase -> initializePicBase_ppc arch os picBase tops -+ Nothing -> return tops -+ ArchPPC_64 ELF_V1 -> return tops -+ -- generating function descriptor is handled in -+ -- pretty printer -+ ArchPPC_64 ELF_V2 -> return tops -+ -- generating function prologue is handled in -+ -- pretty printer -+ _ -> panic "PPC.cmmTopCodeGen: unknown arch" - - cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic -@@ -197,26 +207,6 @@ getRegisterReg platform (CmmGlobal mid) - -- ones which map to a real machine register on this - -- platform. Hence ... - -- --{- --Now, given a tree (the argument to an CmmLoad) that references memory, --produce a suitable addressing mode. -- --A Rule of the Game (tm) for Amodes: use of the addr bit must --immediately follow use of the code part, since the code part puts --values in registers which the addr then refers to. So you can't put --anything in between, lest it overwrite some of those registers. If --you need to do some other computation between the code part and use of --the addr bit, first store the effective address from the amode in a --temporary, then do the other computation, and then use the temporary: -- -- code -- LEA amode, tmp -- ... other computation ... -- ... (tmp) ... ---} -- -- - -- | Convert a BlockId to some CmmStatic data - jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic - jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -@@ -264,7 +254,7 @@ data ChildCode64 -- a.k.a "Regist - -- Reg may be modified - - ---- | The dual to getAnyReg: compute an expression into a register, but -+-- | Compute an expression into a register, but - -- we don't mind which one it is. - getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) - getSomeReg expr = do -@@ -278,7 +268,7 @@ getSomeReg expr = do - - getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) - getI64Amodes addrTree = do -- Amode hi_addr addr_code <- getAmode addrTree -+ Amode hi_addr addr_code <- getAmode D addrTree - case addrOffset hi_addr 4 of - Just lo_addr -> return (hi_addr, lo_addr, addr_code) - Nothing -> do (hi_ptr, code) <- getSomeReg addrTree -@@ -389,10 +379,12 @@ getRegister e = do dflags <- getDynFlags - - getRegister' :: DynFlags -> CmmExpr -> NatM Register - --getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) -- = do -- reg <- getPicBaseNat archWordSize -- return (Fixed archWordSize reg nilOL) -+getRegister' dflags (CmmReg (CmmGlobal PicBaseReg)) -+ | target32Bit (targetPlatform dflags) = do -+ reg <- getPicBaseNat $ archWordSize (target32Bit (targetPlatform dflags)) -+ return (Fixed (archWordSize (target32Bit (targetPlatform dflags))) -+ reg nilOL) -+ | otherwise = return (Fixed II64 toc nilOL) - - getRegister' dflags (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType dflags reg)) -@@ -427,30 +419,54 @@ getRegister' dflags (CmmMachOp (MO_SS_Co - return $ Fixed II32 rlo code - - getRegister' dflags (CmmLoad mem pk) -- | not (isWord64 pk) -- = do -+ | not (isWord64 pk) = do - let platform = targetPlatform dflags -- Amode addr addr_code <- getAmode mem -+ Amode addr addr_code <- getAmode D mem - let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) - addr_code `snocOL` LD size dst addr - return (Any size code) -+ | not (target32Bit (targetPlatform dflags)) = do -+ Amode addr addr_code <- getAmode DS mem -+ let code dst = addr_code `snocOL` LD II64 dst addr -+ return (Any II64 code) -+ - where size = cmmTypeSize pk - - -- catch simple cases of zero- or sign-extended load - getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do -- Amode addr addr_code <- getAmode mem -+ Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) - -+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do -+ Amode addr addr_code <- getAmode D mem -+ return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) -+ - -- Note: there is no Load Byte Arithmetic instruction, so no signed case here - - getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do -- Amode addr addr_code <- getAmode mem -+ Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) - - getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do -- Amode addr addr_code <- getAmode mem -+ Amode addr addr_code <- getAmode D mem - return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) - -+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do -+ Amode addr addr_code <- getAmode D mem -+ return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) -+ -+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do -+ Amode addr addr_code <- getAmode D mem -+ return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) -+ -+getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do -+ Amode addr addr_code <- getAmode D mem -+ return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) -+ -+getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do -+ Amode addr addr_code <- getAmode D mem -+ return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) -+ - getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps - = case mop of - MO_Not rep -> triv_ucode_int rep NOT -@@ -468,7 +484,16 @@ getRegister' dflags (CmmMachOp mop [x]) - | from == to -> conversionNop (intSize to) x - - -- narrowing is a nop: we treat the high bits as undefined -- MO_SS_Conv W32 to -> conversionNop (intSize to) x -+ MO_SS_Conv W64 to -+ | arch32 -> panic "PPC.CodeGen.getRegister no 64 bit int register" -+ | otherwise -> conversionNop (intSize to) x -+ MO_SS_Conv W32 to -+ | arch32 -> conversionNop (intSize to) x -+ | otherwise -> case to of -+ W64 -> triv_ucode_int to (EXTS II32) -+ W16 -> conversionNop II16 x -+ W8 -> conversionNop II8 x -+ _ -> panic "PPC.CodeGen.getRegister: no match" - MO_SS_Conv W16 W8 -> conversionNop II8 x - MO_SS_Conv W8 to -> triv_ucode_int to (EXTS II8) - MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16) -@@ -476,7 +501,17 @@ getRegister' dflags (CmmMachOp mop [x]) - MO_UU_Conv from to - | from == to -> conversionNop (intSize to) x - -- narrowing is a nop: we treat the high bits as undefined -- MO_UU_Conv W32 to -> conversionNop (intSize to) x -+ MO_UU_Conv W64 to -+ | arch32 -> panic "PPC.CodeGen.getRegister no 64 bit target" -+ | otherwise -> conversionNop (intSize to) x -+ MO_UU_Conv W32 to -+ | arch32 -> conversionNop (intSize to) x -+ | otherwise -> -+ case to of -+ W64 -> trivialCode to False AND x (CmmLit (CmmInt 4294967295 W64)) -+ W16 -> conversionNop II16 x -+ W8 -> conversionNop II8 x -+ _ -> panic "PPC.CodeGen.getRegister: no match" - MO_UU_Conv W16 W8 -> conversionNop II8 x - MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32)) - MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) -@@ -489,8 +524,9 @@ getRegister' dflags (CmmMachOp mop [x]) - conversionNop new_size expr - = do e_code <- getRegister' dflags expr - return (swizzleRegisterRep e_code new_size) -+ arch32 = target32Bit $ targetPlatform dflags - --getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps -+getRegister' dflags (CmmMachOp mop [x, y]) -- dyadic PrimOps - = case mop of - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y -@@ -499,18 +535,28 @@ getRegister' _ (CmmMachOp mop [x, y]) -- - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - -- MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y) -- MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y) -- -- MO_S_Gt rep -> condIntReg GTT (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Ge rep -> condIntReg GE (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Lt rep -> condIntReg LTT (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Le rep -> condIntReg LE (extendSExpr rep x) (extendSExpr rep y) -- -- MO_U_Gt rep -> condIntReg GU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Ge rep -> condIntReg GEU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Lt rep -> condIntReg LU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Le rep -> condIntReg LEU (extendUExpr rep x) (extendUExpr rep y) -+ MO_Eq rep -> condIntReg EQQ (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ MO_Ne rep -> condIntReg NE (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ -+ MO_S_Gt rep -> condIntReg GTT (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Ge rep -> condIntReg GE (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Lt rep -> condIntReg LTT (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Le rep -> condIntReg LE (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ -+ MO_U_Gt rep -> condIntReg GU (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ MO_U_Ge rep -> condIntReg GEU (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ MO_U_Lt rep -> condIntReg LU (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ MO_U_Le rep -> condIntReg LEU (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) - - MO_F_Add w -> triv_float w FADD - MO_F_Sub w -> triv_float w FSUB -@@ -541,32 +587,53 @@ getRegister' _ (CmmMachOp mop [x, y]) -- - -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep) - _ -> trivialCodeNoImm' (intSize rep) SUBF y x - -- MO_Mul rep -> trivialCode rep True MULLW x y -+ MO_Mul rep -+ | arch32 -> trivialCode rep True MULLW x y -+ | otherwise -> trivialCode rep True MULLD x y - - MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y -+ MO_S_MulMayOflo W64 -> trivialCodeNoImm' II64 MULLD_MayOflo x y - -- MO_S_MulMayOflo _ -> panic "S_MulMayOflo (rep /= II32): not implemented" -+ MO_S_MulMayOflo _ -> panic "S_MulMayOflo: (II8/16) not implemented" - MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented" - -- MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y) -- MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y) -- -- MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y) -- MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y) -+ MO_S_Quot rep -+ | arch32 -> trivialCodeNoImm' (intSize rep) DIVW -+ (extendSExpr dflags rep x) (extendSExpr dflags rep y) -+ | otherwise -> trivialCodeNoImm' (intSize rep) DIVD -+ (extendSExpr dflags rep x) (extendSExpr dflags rep y) -+ MO_U_Quot rep -+ | arch32 -> trivialCodeNoImm' (intSize rep) DIVWU -+ (extendUExpr dflags rep x) (extendUExpr dflags rep y) -+ | otherwise -> trivialCodeNoImm' (intSize rep) DIVDU -+ (extendUExpr dflags rep x) (extendUExpr dflags rep y) -+ -+ MO_S_Rem rep -+ | arch32 -> remainderCode rep DIVW (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ | otherwise -> remainderCode rep DIVD (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_U_Rem rep -+ | arch32 -> remainderCode rep DIVWU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ | otherwise -> remainderCode rep DIVDU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) - - MO_And rep -> trivialCode rep False AND x y - MO_Or rep -> trivialCode rep False OR x y - MO_Xor rep -> trivialCode rep False XOR x y - -- MO_Shl rep -> trivialCode rep False SLW x y -- MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y -- MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y -+ MO_Shl rep -> shiftCode rep SL x y -+ MO_S_Shr rep -> shiftCode rep SRA (extendSExpr dflags rep x) y -+ MO_U_Shr rep -> shiftCode rep SR (extendUExpr dflags rep x) y - _ -> panic "PPC.CodeGen.getRegister: no match" - - where - triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register - triv_float width instr = trivialCodeNoImm (floatSize width) instr x y - -+ arch32 = target32Bit $ targetPlatform dflags -+ - getRegister' _ (CmmLit (CmmInt i rep)) - | Just imm <- makeImmediate rep True i - = let -@@ -578,7 +645,7 @@ getRegister' _ (CmmLit (CmmFloat f frep) - lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl -- Amode addr addr_code <- getAmode dynRef -+ Amode addr addr_code <- getAmode D dynRef - let size = floatSize frep - code dst = - LDATA ReadOnlyData (Statics lbl -@@ -587,6 +654,7 @@ getRegister' _ (CmmLit (CmmFloat f frep) - return (Any size code) - - getRegister' dflags (CmmLit lit) -+ | target32Bit (targetPlatform dflags) - = let rep = cmmLitType dflags lit - imm = litToImm lit - code dst = toOL [ -@@ -594,18 +662,46 @@ getRegister' dflags (CmmLit lit) - ADD dst dst (RIImm (LO imm)) - ] - in return (Any (cmmTypeSize rep) code) -+ | otherwise -+ = do lbl <- getNewLabelNat -+ dflags <- getDynFlags -+ dynRef <- cmmMakeDynamicReference dflags DataReference lbl -+ Amode addr addr_code <- getAmode D dynRef -+ let rep = cmmLitType dflags lit -+ size = cmmTypeSize rep -+ code dst = -+ LDATA ReadOnlyData (Statics lbl -+ [CmmStaticLit lit]) -+ `consOL` (addr_code `snocOL` LD size dst addr) -+ return (Any size code) - - getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) - - -- extend?Rep: wrap integer expression of type rep -- -- in a conversion to II32 --extendSExpr :: Width -> CmmExpr -> CmmExpr --extendSExpr W32 x = x --extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x] -- --extendUExpr :: Width -> CmmExpr -> CmmExpr --extendUExpr W32 x = x --extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x] -+ -- in a conversion to II32 or II64 resp. -+extendSExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr -+extendSExpr dflags W32 x -+ | target32Bit (targetPlatform dflags) = x -+ -+extendSExpr dflags W64 x -+ | not (target32Bit (targetPlatform dflags)) = x -+ -+extendSExpr dflags rep x = -+ let size = if target32Bit $ targetPlatform dflags -+ then W32 -+ else W64 -+ in CmmMachOp (MO_SS_Conv rep size) [x] -+ -+extendUExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr -+extendUExpr dflags W32 x -+ | target32Bit (targetPlatform dflags) = x -+extendUExpr dflags W64 x -+ | not (target32Bit (targetPlatform dflags)) = x -+extendUExpr dflags rep x = -+ let size = if target32Bit $ targetPlatform dflags -+ then W32 -+ else W64 -+ in CmmMachOp (MO_UU_Conv rep size) [x] - - -- ----------------------------------------------------------------------------- - -- The 'Amode' type: Memory addressing modes passed up the tree. -@@ -631,26 +727,68 @@ temporary, then do the other computation - ... (tmp) ... - -} - --getAmode :: CmmExpr -> NatM Amode --getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags -- getAmode (mangleIndexTree dflags tree) -+data InstrForm = D | DS - --getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) -+getAmode :: InstrForm -> CmmExpr -> NatM Amode -+getAmode inf tree@(CmmRegOff _ _) -+ = do dflags <- getDynFlags -+ getAmode inf (mangleIndexTree dflags tree) -+ -+getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True (-i) - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - - --getAmode (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) -+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)]) - | Just off <- makeImmediate W32 True i - = do - (reg, code) <- getSomeReg x - return (Amode (AddrRegImm reg off) code) - -+getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) -+ | Just off <- makeImmediate W64 True (-i) -+ = do -+ (reg, code) <- getSomeReg x -+ return (Amode (AddrRegImm reg off) code) -+ -+ -+getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) -+ | Just off <- makeImmediate W64 True i -+ = do -+ (reg, code) <- getSomeReg x -+ return (Amode (AddrRegImm reg off) code) -+ -+getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)]) -+ | Just off <- makeImmediate W64 True (-i) -+ = do -+ (reg, code) <- getSomeReg x -+ (reg', off', code') <- -+ if i `mod` 4 == 0 -+ then do return (reg, off, code) -+ else do -+ tmp <- getNewRegNat II64 -+ return (tmp, ImmInt 0, -+ code `snocOL` ADD tmp reg (RIImm off)) -+ return (Amode (AddrRegImm reg' off') code') -+ -+getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) -+ | Just off <- makeImmediate W64 True i -+ = do -+ (reg, code) <- getSomeReg x -+ (reg', off', code') <- -+ if i `mod` 4 == 0 -+ then do return (reg, off, code) -+ else do -+ tmp <- getNewRegNat II64 -+ return (tmp, ImmInt 0, -+ code `snocOL` ADD tmp reg (RIImm off)) -+ return (Amode (AddrRegImm reg' off') code') -+ - -- optimize addition with 32-bit immediate - -- (needed for PIC) --getAmode (CmmMachOp (MO_Add W32) [x, CmmLit lit]) -+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) - = do - tmp <- getNewRegNat II32 - (src, srcCode) <- getSomeReg x -@@ -658,20 +796,40 @@ getAmode (CmmMachOp (MO_Add W32) [x, Cmm - code = srcCode `snocOL` ADDIS tmp src (HA imm) - return (Amode (AddrRegImm tmp (LO imm)) code) - --getAmode (CmmLit lit) -+getAmode _ (CmmLit lit) - = do -- tmp <- getNewRegNat II32 -- let imm = litToImm lit -- code = unitOL (LIS tmp (HA imm)) -- return (Amode (AddrRegImm tmp (LO imm)) code) -+ dflags <- getDynFlags -+ case platformArch $ targetPlatform dflags of -+ ArchPPC -> do -+ tmp <- getNewRegNat II32 -+ let imm = litToImm lit -+ code = unitOL (LIS tmp (HA imm)) -+ return (Amode (AddrRegImm tmp (LO imm)) code) -+ _ -> do -- TODO: Load from TOC, -+ -- see getRegister' _ (CmmLit lit) -+ tmp <- getNewRegNat II64 -+ let imm = litToImm lit -+ code = toOL [ -+ LIS tmp (HIGHESTA imm), -+ OR tmp tmp (RIImm (HIGHERA imm)), -+ SL II64 tmp tmp (RIImm (ImmInt 32)), -+ ORIS tmp tmp (HA imm) -+ ] -+ return (Amode (AddrRegImm tmp (LO imm)) code) -+ -+getAmode _ (CmmMachOp (MO_Add W32) [x, y]) -+ = do -+ (regX, codeX) <- getSomeReg x -+ (regY, codeY) <- getSomeReg y -+ return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - --getAmode (CmmMachOp (MO_Add W32) [x, y]) -+getAmode _ (CmmMachOp (MO_Add W64) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - --getAmode other -+getAmode _ other - = do - (reg, code) <- getSomeReg other - let -@@ -679,7 +837,6 @@ getAmode other - return (Amode (AddrRegImm reg off) code) - - -- - -- The 'CondCode' type: Condition codes passed up the tree. - data CondCode - = CondCode Bool Cond InstrBlock -@@ -689,10 +846,12 @@ data CondCode - getCondCode :: CmmExpr -> NatM CondCode - - -- almost the same as everywhere else - but we need to ---- extend small integers to 32 bit first -+-- extend small integers to 32 bit or 64 bit first - - getCondCode (CmmMachOp mop [x, y]) -- = case mop of -+ = do -+ dflags <- getDynFlags -+ case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y -@@ -707,18 +866,28 @@ getCondCode (CmmMachOp mop [x, y]) - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - -- MO_Eq rep -> condIntCode EQQ (extendUExpr rep x) (extendUExpr rep y) -- MO_Ne rep -> condIntCode NE (extendUExpr rep x) (extendUExpr rep y) -- -- MO_S_Gt rep -> condIntCode GTT (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Ge rep -> condIntCode GE (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Lt rep -> condIntCode LTT (extendSExpr rep x) (extendSExpr rep y) -- MO_S_Le rep -> condIntCode LE (extendSExpr rep x) (extendSExpr rep y) -- -- MO_U_Gt rep -> condIntCode GU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Ge rep -> condIntCode GEU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y) -- MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y) -+ MO_Eq rep -> condIntCode EQQ (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ MO_Ne rep -> condIntCode NE (extendUExpr dflags rep x) -+ (extendUExpr dflags rep y) -+ -+ MO_S_Gt rep -> condIntCode GTT (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Ge rep -> condIntCode GE (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Lt rep -> condIntCode LTT (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_S_Le rep -> condIntCode LE (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ -+ MO_U_Gt rep -> condIntCode GU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_U_Ge rep -> condIntCode GEU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_U_Lt rep -> condIntCode LU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) -+ MO_U_Le rep -> condIntCode LEU (extendSExpr dflags rep x) -+ (extendSExpr dflags rep y) - - _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) - -@@ -732,21 +901,24 @@ getCondCode _ = panic "getCondCode(2)(po - condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode - - -- ###FIXME: I16 and I8! -+-- TODO: Is this still an issue? All arguments are extend?Expr'd. - condIntCode cond x (CmmLit (CmmInt y rep)) - | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y - = do - (src1, code) <- getSomeReg x -- let -+ dflags <- getDynFlags -+ let size = archWordSize $ target32Bit $ targetPlatform dflags - code' = code `snocOL` -- (if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2) -+ (if condUnsigned cond then CMPL else CMP) size src1 (RIImm src2) - return (CondCode False cond code') - - condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y -- let -+ dflags <- getDynFlags -+ let size = archWordSize $ target32Bit $ targetPlatform dflags - code' = code1 `appOL` code2 `snocOL` -- (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2) -+ (if condUnsigned cond then CMPL else CMP) size src1 (RIReg src2) - return (CondCode False cond code') - - condFltCode cond x y = do -@@ -784,7 +956,9 @@ assignReg_FltCode :: Size -> CmmReg -> - - assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src -- Amode dstAddr addr_code <- getAmode addr -+ Amode dstAddr addr_code <- case pk of -+ II64 -> getAmode DS addr -+ _ -> getAmode D addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -- dst is a reg, but src could be anything -@@ -812,9 +986,42 @@ genJump (CmmLit (CmmLabel lbl)) - - genJump tree - = do -+ dflags <- getDynFlags -+ let platform = targetPlatform dflags -+ case platformOS platform of -+ OSLinux -> case platformArch platform of -+ ArchPPC -> genJump' tree GCPLinux -+ ArchPPC_64 ELF_V1 -> genJump' tree (GCPLinux64ELF 1) -+ ArchPPC_64 ELF_V2 -> genJump' tree (GCPLinux64ELF 2) -+ _ -> panic "PPC.CodeGen.genJump: Unknown Linux" -+ OSDarwin -> genJump' tree GCPDarwin -+ _ -> panic "PPC.CodeGen.genJump: not defined for this os" -+ -+ -+genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock -+ -+genJump' tree (GCPLinux64ELF 1) -+ = do - (target,code) <- getSomeReg tree -- return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) -+ return (code -+ `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0)) -+ `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8)) -+ `snocOL` MTCTR r11 -+ `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16)) -+ `snocOL` BCTR [] Nothing) -+ -+genJump' tree (GCPLinux64ELF 2) -+ = do -+ (target,code) <- getSomeReg tree -+ return (code -+ `snocOL` MR r12 target -+ `snocOL` MTCTR r12 -+ `snocOL` BCTR [] Nothing) - -+genJump' tree _ -+ = do -+ (target,code) <- getSomeReg tree -+ return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) - - -- ----------------------------------------------------------------------------- - -- Unconditional branches -@@ -861,11 +1068,18 @@ genCCall target dest_regs argsAndHints - = do dflags <- getDynFlags - let platform = targetPlatform dflags - case platformOS platform of -- OSLinux -> genCCall' dflags GCPLinux target dest_regs argsAndHints -- OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints -- _ -> panic "PPC.CodeGen.genCCall: not defined for this os" -+ OSLinux -> case platformArch platform of -+ ArchPPC -> genCCall' dflags GCPLinux -+ target dest_regs argsAndHints -+ ArchPPC_64 ELF_V1 -> genCCall' dflags (GCPLinux64ELF 1) -+ target dest_regs argsAndHints -+ ArchPPC_64 ELF_V2 -> genCCall' dflags (GCPLinux64ELF 2) -+ target dest_regs argsAndHints -+ _ -> panic "PPC.CodeGen.genCCall: Unknown Linux" -+ OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints -+ _ -> panic "PPC.CodeGen.genCCall: not defined for this os" - --data GenCCallPlatform = GCPLinux | GCPDarwin -+data GenCCallPlatform = GCPLinux | GCPDarwin | GCPLinux64ELF Int - - genCCall' - :: DynFlags -@@ -904,7 +1118,11 @@ genCCall' - * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on - PowerPC Linux does not agree, so neither do we. - -- According to both conventions, The parameter area should be part of the -+ PowerPC 64 Linux uses the System V Release 4 Calling Convention for -+ 64-bit PowerPC. It is specified in -+ "64-bit PowerPC ELF Application Binary Interface Supplement 1.9". -+ -+ According to all conventions, the parameter area should be part of the - caller's stack frame, allocated in the caller's prologue code (large enough - to hold the parameter lists for all called routines). The NCG already - uses the stack for register spilling, leaving 64 bytes free at the top. -@@ -943,39 +1161,66 @@ genCCall' dflags gcp target dest_regs ar - PrimTarget mop -> outOfLineMachOp mop - - let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode -- codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 -+ `appOL` toc_before -+ codeAfter = toc_after labelOrExpr `appOL` move_sp_up finalStack -+ `appOL` moveResult reduceToFF32 - - case labelOrExpr of -- Left lbl -> do -+ Left lbl -> do -- the linker does all the work for us - return ( codeBefore - `snocOL` BL lbl usedRegs - `appOL` codeAfter) -- Right dyn -> do -+ Right dyn -> do -- implement call through function pointer - (dynReg, dynCode) <- getSomeReg dyn -- return ( dynCode -- `snocOL` MTCTR dynReg -- `appOL` codeBefore -- `snocOL` BCTRL usedRegs -- `appOL` codeAfter) -+ case gcp of -+ GCPLinux64ELF 1 -> return ( dynCode -+ `appOL` codeBefore -+ `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0)) -+ `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8)) -+ `snocOL` MTCTR r11 -+ `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16)) -+ `snocOL` BCTRL usedRegs -+ `appOL` codeAfter) -+ GCPLinux64ELF 2 -> return ( dynCode -+ `appOL` codeBefore -+ `snocOL` MR r12 dynReg -+ `snocOL` MTCTR r12 -+ `snocOL` BCTRL usedRegs -+ `appOL` codeAfter) -+ _ -> return ( dynCode -+ `snocOL` MTCTR dynReg -+ `appOL` codeBefore -+ `snocOL` BCTRL usedRegs -+ `appOL` codeAfter) - where - platform = targetPlatform dflags - - uses_pic_base_implicitly = do - -- See Note [implicit register in PPC PIC code] - -- on why we claim to use PIC register here -- when (gopt Opt_PIC dflags) $ do -- _ <- getPicBaseNat archWordSize -+ when (gopt Opt_PIC dflags && target32Bit platform) $ do -+ _ <- getPicBaseNat $ archWordSize True - return () - - initialStackOffset = case gcp of -- GCPDarwin -> 24 -- GCPLinux -> 8 -+ GCPDarwin -> 24 -+ GCPLinux -> 8 -+ GCPLinux64ELF 1 -> 48 -+ GCPLinux64ELF 2 -> 32 -+ _ -> panic "genCall': unknown calling convention" - -- size of linkage area + size of arguments, in bytes - stackDelta finalStack = case gcp of - GCPDarwin -> - roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps - GCPLinux -> roundTo 16 finalStack -+ GCPLinux64ELF 1 -> -+ roundTo 16 $ (48 +) $ max 64 $ sum $ -+ map (widthInBytes . typeWidth) argReps -+ GCPLinux64ELF 2 -> -+ roundTo 16 $ (32 +) $ max 64 $ sum $ -+ map (widthInBytes . typeWidth) argReps -+ _ -> panic "genCall': unknown calling conv." - - -- need to remove alignment information - args | PrimTarget mop <- target, -@@ -992,14 +1237,34 @@ genCCall' dflags gcp target dest_regs ar - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - -+ spSize = if target32Bit platform then II32 else II64 -+ - move_sp_down finalStack - | delta > 64 = -- toOL [STU II32 sp (AddrRegImm sp (ImmInt (-delta))), -+ toOL [STU spSize sp (AddrRegImm sp (ImmInt (-delta))), - DELTA (-delta)] - | otherwise = nilOL - where delta = stackDelta finalStack -+ toc_before = case gcp of -+ GCPLinux64ELF 1 -> unitOL $ ST spSize toc (AddrRegImm sp (ImmInt 40)) -+ GCPLinux64ELF 2 -> unitOL $ ST spSize toc (AddrRegImm sp (ImmInt 24)) -+ _ -> nilOL -+ toc_after labelOrExpr = case gcp of -+ GCPLinux64ELF 1 -> case labelOrExpr of -+ Left _ -> toOL [ NOP ] -+ Right _ -> toOL [ LD spSize toc -+ (AddrRegImm sp -+ (ImmInt 40)) -+ ] -+ GCPLinux64ELF 2 -> case labelOrExpr of -+ Left _ -> toOL [ NOP ] -+ Right _ -> toOL [ LD spSize toc -+ (AddrRegImm sp -+ (ImmInt 24)) -+ ] -+ _ -> nilOL - move_sp_up finalStack -- | delta > 64 = -+ | delta > 64 = -- TODO: fix-up stack back-chain - toOL [ADD sp sp (RIImm (ImmInt delta)), - DELTA 0] - | otherwise = nilOL -@@ -1008,7 +1273,8 @@ genCCall' dflags gcp target dest_regs ar - - passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) - passArguments ((arg,arg_ty):args) gprs fprs stackOffset -- accumCode accumUsed | isWord64 arg_ty = -+ accumCode accumUsed | isWord64 arg_ty -+ && target32Bit (targetPlatform dflags) = - do - ChildCode64 code vr_lo <- iselExpr64 arg - let vr_hi = getHiVRegFromLo vr_lo -@@ -1046,6 +1312,7 @@ genCCall' dflags gcp target dest_regs ar - _ -> -- only one or no regs left - passArguments args [] fprs (stackOffset'+8) - stackCode accumUsed -+ GCPLinux64ELF _ -> panic "passArguments: 32 bit code" - - passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed - | reg : _ <- regs = do -@@ -1057,8 +1324,10 @@ genCCall' dflags gcp target dest_regs ar - -- The Darwin ABI requires that we reserve - -- stack slots for register parameters - GCPDarwin -> stackOffset + stackBytes -- -- ... the SysV ABI doesn't. -+ -- ... the SysV ABI 32-bit doesn't. - GCPLinux -> stackOffset -+ -- ... but SysV ABI 64-bit does. -+ GCPLinux64ELF _ -> stackOffset + stackBytes - passArguments args - (drop nGprs gprs) - (drop nFprs fprs) -@@ -1086,6 +1355,11 @@ genCCall' dflags gcp target dest_regs ar - roundTo 8 stackOffset - | otherwise -> - stackOffset -+ GCPLinux64ELF _ -> -+ -- everything on the stack is 8-byte -+ -- aligned on a 64 bit system -+ -- (except vector status, not used now) -+ stackOffset - stackSlot = AddrRegImm sp (ImmInt stackOffset') - (nGprs, nFprs, stackBytes, regs) - = case gcp of -@@ -1111,6 +1385,18 @@ genCCall' dflags gcp target dest_regs ar - FF64 -> (0, 1, 8, fprs) - II64 -> panic "genCCall' passArguments II64" - FF80 -> panic "genCCall' passArguments FF80" -+ GCPLinux64ELF _ -> -+ case cmmTypeSize rep of -+ II8 -> (1, 0, 8, gprs) -+ II16 -> (1, 0, 8, gprs) -+ II32 -> (1, 0, 8, gprs) -+ II64 -> (1, 0, 8, gprs) -+ -- The ELFv1 ABI requires that we skip a -+ -- corresponding number of GPRs when we use -+ -- the FPRs. -+ FF32 -> (1, 1, 8, fprs) -+ FF64 -> (1, 1, 8, fprs) -+ FF80 -> panic "genCCall' passArguments FF80" - - moveResult reduceToFF32 = - case dest_regs of -@@ -1118,8 +1404,9 @@ genCCall' dflags gcp target dest_regs ar - [dest] - | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) - | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) -- | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, -- MR r_dest r4] -+ | isWord64 rep && target32Bit (targetPlatform dflags) -+ -> toOL [MR (getHiVRegFromLo r_dest) r3, -+ MR r_dest r4] - | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType dflags (CmmLocal dest) - r_dest = getRegisterReg platform (CmmLocal dest) -@@ -1203,17 +1490,19 @@ genCCall' dflags gcp target dest_regs ar - - genSwitch :: DynFlags -> CmmExpr -> [Maybe BlockId] -> NatM InstrBlock - genSwitch dflags expr ids -- | gopt Opt_PIC dflags -+ | (gopt Opt_PIC dflags) || (not $ target32Bit $ targetPlatform dflags) - = do - (reg,e_code) <- getSomeReg expr -- tmp <- getNewRegNat II32 -+ let sz = archWordSize $ target32Bit $ targetPlatform dflags -+ sha = if target32Bit $ targetPlatform dflags then 2 else 3 -+ tmp <- getNewRegNat sz - lbl <- getNewLabelNat - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl - (tableReg,t_code) <- getSomeReg $ dynRef - let code = e_code `appOL` t_code `appOL` toOL [ -- SLW tmp reg (RIImm (ImmInt 2)), -- LD II32 tmp (AddrRegReg tableReg tmp), -+ SL sz tmp reg (RIImm (ImmInt sha)), -+ LD sz tmp (AddrRegReg tableReg tmp), - ADD tmp tmp (RIReg tableReg), - MTCTR tmp, - BCTR ids (Just lbl) -@@ -1222,12 +1511,14 @@ genSwitch dflags expr ids - | otherwise - = do - (reg,e_code) <- getSomeReg expr -- tmp <- getNewRegNat II32 -+ let sz = archWordSize $ target32Bit $ targetPlatform dflags -+ sha = if target32Bit $ targetPlatform dflags then 2 else 3 -+ tmp <- getNewRegNat sz - lbl <- getNewLabelNat - let code = e_code `appOL` toOL [ -- SLW tmp reg (RIImm (ImmInt 2)), -+ SL sz tmp reg (RIImm (ImmInt 2)), - ADDIS tmp tmp (HA (ImmCLbl lbl)), -- LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), -+ LD sz tmp (AddrRegImm tmp (LO (ImmCLbl lbl))), - MTCTR tmp, - BCTR ids (Just lbl) - ] -@@ -1237,7 +1528,9 @@ generateJumpTableForInstr :: DynFlags -> - -> Maybe (NatCmmDecl CmmStatics Instr) - generateJumpTableForInstr dflags (BCTR ids (Just lbl)) = - let jumpTable -- | gopt Opt_PIC dflags = map jumpTableEntryRel ids -+ | (gopt Opt_PIC dflags) -+ || (not $ target32Bit $ targetPlatform dflags) -+ = map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids - where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -@@ -1252,25 +1545,14 @@ generateJumpTableForInstr _ _ = Nothing - - -- Turn those condition codes into integers now (when they appear on - -- the right hand side of an assignment). ---- ---- (If applicable) Do not fill the delay slots here; you will confuse the ---- register allocator. - - condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register - - condReg :: NatM CondCode -> NatM Register - condReg getCond = do - CondCode _ cond cond_code <- getCond -+ dflags <- getDynFlags - let --{- code dst = cond_code `appOL` toOL [ -- BCC cond lbl1, -- LI dst (ImmInt 0), -- BCC ALWAYS lbl2, -- NEWBLOCK lbl1, -- LI dst (ImmInt 1), -- BCC ALWAYS lbl2, -- NEWBLOCK lbl2 -- ]-} - code dst = cond_code - `appOL` negate_code - `appOL` toOL [ -@@ -1296,7 +1578,8 @@ condReg getCond = do - GU -> (1, False) - _ -> panic "PPC.CodeGen.codeReg: no match" - -- return (Any II32 code) -+ size = archWordSize $ target32Bit $ targetPlatform dflags -+ return (Any size code) - - condIntReg cond x y = condReg (condIntCode cond x y) - condFltReg cond x y = condReg (condFltCode cond x y) -@@ -1365,6 +1648,27 @@ trivialCode rep _ instr x y = do - let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2) - return (Any (intSize rep) code) - -+shiftCode -+ :: Width -+ -> (Size-> Reg -> Reg -> RI -> Instr) -+ -> CmmExpr -+ -> CmmExpr -+ -> NatM Register -+shiftCode width instr x (CmmLit (CmmInt y _)) -+ | Just imm <- makeImmediate width False y -+ = do -+ (src1, code1) <- getSomeReg x -+ let size = intSize width -+ let code dst = code1 `snocOL` instr size dst src1 (RIImm imm) -+ return (Any size code) -+ -+shiftCode width instr x y = do -+ (src1, code1) <- getSomeReg x -+ (src2, code2) <- getSomeReg y -+ let size = intSize width -+ let code dst = code1 `appOL` code2 `snocOL` instr size dst src1 (RIReg src2) -+ return (Any size code) -+ - trivialCodeNoImm' :: Size -> (Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register - trivialCodeNoImm' size instr x y = do -@@ -1395,25 +1699,33 @@ trivialUCode rep instr x = do - remainderCode :: Width -> (Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register - remainderCode rep div x y = do -+ dflags <- getDynFlags -+ let mull_instr = if target32Bit $ targetPlatform dflags then MULLW -+ else MULLD - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let code dst = code1 `appOL` code2 `appOL` toOL [ - div dst src1 src2, -- MULLW dst dst (RIReg src2), -+ mull_instr dst dst (RIReg src2), - SUBF dst dst src1 - ] - return (Any (intSize rep) code) - -- - coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register - coerceInt2FP fromRep toRep x = do -+ dflags <- getDynFlags -+ let arch = platformArch $ targetPlatform dflags -+ coerceInt2FP' arch fromRep toRep x -+ -+coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -+coerceInt2FP' ArchPPC fromRep toRep x = do - (src, code) <- getSomeReg x - lbl <- getNewLabelNat - itmp <- getNewRegNat II32 - ftmp <- getNewRegNat FF64 - dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags DataReference lbl -- Amode addr addr_code <- getAmode dynRef -+ Amode addr addr_code <- getAmode D dynRef - let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData $ Statics lbl -@@ -1443,8 +1755,46 @@ coerceInt2FP fromRep toRep x = do - - return (Any (floatSize toRep) code') - -+-- On an ELF v1 Linux we use the compiler doubleword in the stack frame -+-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only -+-- set right before a call and restored right after return from the call. -+-- So it is fine. -+coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do -+ (src, code) <- getSomeReg x -+ dflags <- getDynFlags -+ let -+ code' dst = code `appOL` maybe_exts `appOL` toOL [ -+ ST II64 src (spRel dflags 3), -+ LD FF64 dst (spRel dflags 3), -+ FCFID dst dst -+ ] `appOL` maybe_frsp dst -+ -+ maybe_exts = case fromRep of -+ W8 -> unitOL $ EXTS II8 src src -+ W16 -> unitOL $ EXTS II16 src src -+ W32 -> unitOL $ EXTS II32 src src -+ W64 -> nilOL -+ _ -> panic "PPC.CodeGen.coerceInt2FP: no match" -+ -+ maybe_frsp dst -+ = case toRep of -+ W32 -> unitOL $ FRSP dst dst -+ W64 -> nilOL -+ _ -> panic "PPC.CodeGen.coerceInt2FP: no match" -+ -+ return (Any (floatSize toRep) code') -+ -+coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" -+ -+ - coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register --coerceFP2Int _ toRep x = do -+coerceFP2Int fromRep toRep x = do -+ dflags <- getDynFlags -+ let arch = platformArch $ targetPlatform dflags -+ coerceFP2Int' arch fromRep toRep x -+ -+coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register -+coerceFP2Int' ArchPPC _ toRep x = do - dflags <- getDynFlags - -- the reps don't really matter: F*->FF64 and II32->I* are no-ops - (src, code) <- getSomeReg x -@@ -1459,6 +1809,22 @@ coerceFP2Int _ toRep x = do - LD II32 dst (spRel dflags 3)] - return (Any (intSize toRep) code') - -+coerceFP2Int' (ArchPPC_64 _) _ toRep x = do -+ dflags <- getDynFlags -+ -- the reps don't really matter: F*->FF64 and II64->I* are no-ops -+ (src, code) <- getSomeReg x -+ tmp <- getNewRegNat FF64 -+ let -+ code' dst = code `appOL` toOL [ -+ -- convert to int in FP reg -+ FCTIDZ tmp src, -+ -- store value (64bit) from FP to compiler word on stack -+ ST FF64 tmp (spRel dflags 3), -+ LD II64 dst (spRel dflags 3)] -+ return (Any (intSize toRep) code') -+ -+coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" -+ - -- Note [.LCTOC1 in PPC PIC code] - -- The .LCTOC1 label is defined to point 32768 bytes into the GOT table - -- to make the most of the PPC's 16-bit displacements. -Index: ghc-7.10.2.20151114/compiler/nativeGen/PPC/Instr.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/PPC/Instr.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/PPC/Instr.hs -@@ -49,8 +49,10 @@ import Data.Maybe (fromMaybe) - -------------------------------------------------------------------------------- - -- Size of a PPC memory address, in bytes. - -- --archWordSize :: Size --archWordSize = II32 -+archWordSize :: Bool -> Size -+archWordSize is32Bit -+ | is32Bit = II32 -+ | otherwise = II64 - - - -- | Instruction instance for powerpc -@@ -75,12 +77,14 @@ ppc_mkStackAllocInstr :: Platform -> Int - ppc_mkStackAllocInstr platform amount - = case platformArch platform of - ArchPPC -> UPDATE_SP II32 (ImmInt (-amount)) -+ ArchPPC_64 _ -> STU II64 sp (AddrRegImm sp (ImmInt (-amount))) - arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch - - ppc_mkStackDeallocInstr :: Platform -> Int -> Instr - ppc_mkStackDeallocInstr platform amount - = case platformArch platform of - ArchPPC -> UPDATE_SP II32 (ImmInt amount) -+ ArchPPC_64 _ -> ADD sp sp (RIImm (ImmInt amount)) - arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch - - -- -@@ -210,9 +214,12 @@ data Instr - | SUBF Reg Reg Reg -- dst, src1, src2 ; dst = src2 - src1 - | SUBFC Reg Reg Reg -- (carrying) dst, src1, src2 ; dst = src2 - src1 - | SUBFE Reg Reg Reg -- (extend) dst, src1, src2 ; dst = src2 - src1 -+ | MULLD Reg Reg RI - | MULLW Reg Reg RI - | DIVW Reg Reg Reg -+ | DIVD Reg Reg Reg - | DIVWU Reg Reg Reg -+ | DIVDU Reg Reg Reg - - | MULLW_MayOflo Reg Reg Reg - -- dst = 1 if src1 * src2 overflows -@@ -220,9 +227,16 @@ data Instr - -- mullwo. dst, src1, src2 - -- mfxer dst - -- rlwinm dst, dst, 2, 31,31 -+ | MULLD_MayOflo Reg Reg Reg -+ -- dst = 1 if src1 * src2 overflows -+ -- pseudo-instruction; pretty-printed as: -+ -- mulldo. dst, src1, src2 -+ -- mfxer dst -+ -- rlwinm dst, dst, 2, 31,31 - - | AND Reg Reg RI -- dst, src1, src2 - | OR Reg Reg RI -- dst, src1, src2 -+ | ORIS Reg Reg Imm -- OR Immediate Shifted dst, src1, src2 - | XOR Reg Reg RI -- dst, src1, src2 - | XORIS Reg Reg Imm -- XOR Immediate Shifted dst, src1, src2 - -@@ -231,9 +245,9 @@ data Instr - | NEG Reg Reg - | NOT Reg Reg - -- | SLW Reg Reg RI -- shift left word -- | SRW Reg Reg RI -- shift right word -- | SRAW Reg Reg RI -- shift right arithmetic word -+ | SL Size Reg Reg RI -- shift left -+ | SR Size Reg Reg RI -- shift right -+ | SRA Size Reg Reg RI -- shift right arithmetic - - | RLWINM Reg Reg Int Int Int -- Rotate Left Word Immediate then AND with Mask - -@@ -246,6 +260,8 @@ data Instr - | FCMP Reg Reg - - | FCTIWZ Reg Reg -- convert to integer word -+ | FCTIDZ Reg Reg -- convert to integer double word -+ | FCFID Reg Reg -- convert from integer double word - | FRSP Reg Reg -- reduce to single precision - -- (but destination is a FP register) - -@@ -255,11 +271,16 @@ data Instr - | MFLR Reg -- move from link register - | FETCHPC Reg -- pseudo-instruction: - -- bcl to next insn, mflr reg -- -+ | FETCHTOC Reg CLabel -- pseudo-instruction -+ -- add TOC offset to address in r12 -+ -- print .localentry for label - | LWSYNC -- memory barrier - - | UPDATE_SP Size Imm -- expand/shrink spill area on C stack - -- pseudo-instruction -+ | NOP -- no operation, PowerPC 64 bit -+ -- needs this as place holder to -+ -- reload TOC pointer - - - -- | Get the registers that are being used by this instruction. -@@ -297,22 +318,28 @@ ppc_regUsageOfInstr platform instr - SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) -+ MULLD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - MULLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - DIVW reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) -+ DIVD reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - DIVWU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) -+ DIVDU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1]) - - MULLW_MayOflo reg1 reg2 reg3 - -> usage ([reg2,reg3], [reg1]) -+ MULLD_MayOflo reg1 reg2 reg3 -+ -> usage ([reg2,reg3], [reg1]) - AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -+ ORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - XORIS reg1 reg2 _ -> usage ([reg2], [reg1]) - EXTS _ reg1 reg2 -> usage ([reg2], [reg1]) - NEG reg1 reg2 -> usage ([reg2], [reg1]) - NOT reg1 reg2 -> usage ([reg2], [reg1]) -- SLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -- SRW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -- SRAW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -+ SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -+ SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) -+ SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1]) - RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1]) - - FADD _ r1 r2 r3 -> usage ([r2,r3], [r1]) -@@ -322,10 +349,13 @@ ppc_regUsageOfInstr platform instr - FNEG r1 r2 -> usage ([r2], [r1]) - FCMP r1 r2 -> usage ([r1,r2], []) - FCTIWZ r1 r2 -> usage ([r2], [r1]) -+ FCTIDZ r1 r2 -> usage ([r2], [r1]) -+ FCFID r1 r2 -> usage ([r2], [r1]) - FRSP r1 r2 -> usage ([r2], [r1]) - MFCR reg -> usage ([], [reg]) - MFLR reg -> usage ([], [reg]) - FETCHPC reg -> usage ([], [reg]) -+ FETCHTOC reg _ -> usage ([], [reg]) - UPDATE_SP _ _ -> usage ([], [sp]) - _ -> noUsage - where -@@ -377,21 +407,27 @@ ppc_patchRegsOfInstr instr env - SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3) - SUBFC reg1 reg2 reg3 -> SUBFC (env reg1) (env reg2) (env reg3) - SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3) -+ MULLD reg1 reg2 ri -> MULLD (env reg1) (env reg2) (fixRI ri) - MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri) - DIVW reg1 reg2 reg3 -> DIVW (env reg1) (env reg2) (env reg3) -+ DIVD reg1 reg2 reg3 -> DIVD (env reg1) (env reg2) (env reg3) - DIVWU reg1 reg2 reg3 -> DIVWU (env reg1) (env reg2) (env reg3) -+ DIVDU reg1 reg2 reg3 -> DIVDU (env reg1) (env reg2) (env reg3) - MULLW_MayOflo reg1 reg2 reg3 - -> MULLW_MayOflo (env reg1) (env reg2) (env reg3) -+ MULLD_MayOflo reg1 reg2 reg3 -+ -> MULLD_MayOflo (env reg1) (env reg2) (env reg3) - AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri) - OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri) -+ ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm - XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri) - XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm - EXTS sz reg1 reg2 -> EXTS sz (env reg1) (env reg2) - NEG reg1 reg2 -> NEG (env reg1) (env reg2) - NOT reg1 reg2 -> NOT (env reg1) (env reg2) -- SLW reg1 reg2 ri -> SLW (env reg1) (env reg2) (fixRI ri) -- SRW reg1 reg2 ri -> SRW (env reg1) (env reg2) (fixRI ri) -- SRAW reg1 reg2 ri -> SRAW (env reg1) (env reg2) (fixRI ri) -+ SL sz reg1 reg2 ri -> SL sz (env reg1) (env reg2) (fixRI ri) -+ SR sz reg1 reg2 ri -> SR sz (env reg1) (env reg2) (fixRI ri) -+ SRA sz reg1 reg2 ri -> SRA sz (env reg1) (env reg2) (fixRI ri) - RLWINM reg1 reg2 sh mb me - -> RLWINM (env reg1) (env reg2) sh mb me - FADD sz r1 r2 r3 -> FADD sz (env r1) (env r2) (env r3) -@@ -401,10 +437,13 @@ ppc_patchRegsOfInstr instr env - FNEG r1 r2 -> FNEG (env r1) (env r2) - FCMP r1 r2 -> FCMP (env r1) (env r2) - FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) -+ FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) -+ FCFID r1 r2 -> FCFID (env r1) (env r2) - FRSP r1 r2 -> FRSP (env r1) (env r2) - MFCR reg -> MFCR (env reg) - MFLR reg -> MFLR (env reg) - FETCHPC reg -> FETCHPC (env reg) -+ FETCHTOC reg lab -> FETCHTOC (env reg) lab - _ -> instr - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) -@@ -467,11 +506,14 @@ ppc_mkSpillInstr - ppc_mkSpillInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset slot -+ arch = platformArch platform - in - let sz = case targetClassOfReg platform reg of -- RcInteger -> II32 -+ RcInteger -> case arch of -+ ArchPPC -> II32 -+ _ -> II64 - RcDouble -> FF64 -- _ -> panic "PPC.Instr.mkSpillInstr: no match" -+ _ -> panic "PPC.Instr.mkSpillInstr: no match" - instr = case makeImmediate W32 True (off-delta) of - Just _ -> ST - Nothing -> STFAR -- pseudo instruction: 32 bit offsets -@@ -487,9 +529,12 @@ ppc_mkLoadInstr - ppc_mkLoadInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset slot -+ arch = platformArch platform - in - let sz = case targetClassOfReg platform reg of -- RcInteger -> II32 -+ RcInteger -> case arch of -+ ArchPPC -> II32 -+ _ -> II64 - RcDouble -> FF64 - _ -> panic "PPC.Instr.mkLoadInstr: no match" - instr = case makeImmediate W32 True (off-delta) of -@@ -513,8 +558,8 @@ maxSpillSlots dflags - -- = 0 -- useful for testing allocMoreStack - - -- | The number of bytes that the stack pointer should be aligned ---- to. This is 16 both on PPC32 and PPC64 at least for Darwin, but I'm ---- not sure this is correct for other OSes. -+-- to. This is 16 both on PPC32 and PPC64 at least for Darwin, and -+-- Linux (see ELF processor specific supplements). - stackAlign :: Int - stackAlign = 16 - -Index: ghc-7.10.2.20151114/compiler/nativeGen/PPC/Ppr.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/PPC/Ppr.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/PPC/Ppr.hs -@@ -39,11 +39,11 @@ import Unique ( pprUnique - import Platform - import FastString - import Outputable -+import DynFlags - - import Data.Word - import Data.Bits - -- - -- ----------------------------------------------------------------------------- - -- Printing this stuff out - -@@ -54,12 +54,17 @@ pprNatCmmDecl (CmmData section dats) = - pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - case topInfoTable proc of - Nothing -> -+ sdocWithPlatform $ \platform -> - case blocks of - [] -> -- special case for split markers: - pprLabel lbl - blocks -> -- special case for code without info table: - pprSectionHeader Text $$ -- pprLabel lbl $$ -- blocks guaranteed not null, so label needed -+ (case platformArch platform of -+ ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl -+ ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl -+ _ -> pprLabel lbl) $$ -- blocks guaranteed not null, -+ -- so label needed - vcat (map (pprBasicBlock top_info) blocks) - - Just (Statics info_lbl _) -> -@@ -81,6 +86,35 @@ pprNatCmmDecl proc@(CmmProc top_info lbl - else empty) - - -+pprFunctionDescriptor :: CLabel -> SDoc -+pprFunctionDescriptor lab = pprGloblDecl lab -+ $$ text ".section \".opd\",\"aw\"" -+ $$ text ".align 3" -+ $$ ppr lab <> char ':' -+ $$ text ".quad ." -+ <> ppr lab -+ <> text ",.TOC.@tocbase,0" -+ $$ text ".previous" -+ $$ text ".type " -+ <> ppr lab -+ <> text ", @function" -+ $$ char '.' -+ <> ppr lab -+ <> char ':' -+ -+pprFunctionPrologue :: CLabel ->SDoc -+pprFunctionPrologue lab = pprGloblDecl lab -+ $$ text ".type " -+ <> ppr lab -+ <> text ", @function" -+ $$ ppr lab <> char ':' -+ $$ text "0:\taddis\t" <> pprReg toc -+ <> text ",12,.TOC.-0b@ha" -+ $$ text "\taddi\t" <> pprReg toc -+ <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" -+ $$ text "\t.localentry\t" <> ppr lab -+ <> text ",.-" <> ppr lab -+ - pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc - pprBasicBlock info_env (BasicBlock blockid instrs) - = maybe_infotable $$ -@@ -208,6 +242,7 @@ pprSize x - II8 -> sLit "b" - II16 -> sLit "h" - II32 -> sLit "w" -+ II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprSize: no match") -@@ -257,6 +292,18 @@ pprImm (HA i) - then hcat [ text "ha16(", pprImm i, rparen ] - else pprImm i <> text "@ha" - -+pprImm (HIGHERA i) -+ = sdocWithPlatform $ \platform -> -+ if platformOS platform == OSDarwin -+ then panic "PPC.pprImm: highera not implemented on Darwin" -+ else pprImm i <> text "@highera" -+ -+pprImm (HIGHESTA i) -+ = sdocWithPlatform $ \platform -> -+ if platformOS platform == OSDarwin -+ then panic "PPC.pprImm: highesta not implemented on Darwin" -+ else pprImm i <> text "@highesta" -+ - - pprAddr :: AddrMode -> SDoc - pprAddr (AddrRegReg r1 r2) -@@ -270,18 +317,25 @@ pprAddr (AddrRegImm r1 imm) = hcat [ ppr - pprSectionHeader :: Section -> SDoc - pprSectionHeader seg = - sdocWithPlatform $ \platform -> -- let osDarwin = platformOS platform == OSDarwin in -+ let osDarwin = platformOS platform == OSDarwin -+ ppc64 = not $ target32Bit platform -+ in - case seg of - Text -> text ".text\n\t.align 2" -- Data -> text ".data\n\t.align 2" -+ Data -+ | ppc64 -> text ".data\n.align 3" -+ | otherwise -> text ".data\n.align 2" - ReadOnlyData - | osDarwin -> text ".const\n\t.align 2" -+ | ppc64 -> text ".section .rodata\n\t.align 3" - | otherwise -> text ".section .rodata\n\t.align 2" - RelocatableReadOnlyData - | osDarwin -> text ".const_data\n\t.align 2" -+ | ppc64 -> text ".data\n\t.align 3" - | otherwise -> text ".data\n\t.align 2" - UninitialisedData - | osDarwin -> text ".const_data\n\t.align 2" -+ | ppc64 -> text ".section .bss\n\t.align 3" - | otherwise -> text ".section .bss\n\t.align 2" - ReadOnlyData16 - | osDarwin -> text ".const\n\t.align 4" -@@ -293,32 +347,38 @@ pprSectionHeader seg = - pprDataItem :: CmmLit -> SDoc - pprDataItem lit - = sdocWithDynFlags $ \dflags -> -- vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) -+ vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit dflags) - where - imm = litToImm lit -+ archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags - -- ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] -+ ppr_item II8 _ _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - -- ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] -+ ppr_item II32 _ _ = [ptext (sLit "\t.long\t") <> pprImm imm] - -- ppr_item FF32 (CmmFloat r _) -+ ppr_item II64 _ dflags -+ | archPPC_64 dflags = [ptext (sLit "\t.quad\t") <> pprImm imm] -+ -+ -+ ppr_item FF32 (CmmFloat r _) _ - = let bs = floatToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs - -- ppr_item FF64 (CmmFloat r _) -+ ppr_item FF64 (CmmFloat r _) _ - = let bs = doubleToBytes (fromRational r) - in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs - -- ppr_item II16 _ = [ptext (sLit "\t.short\t") <> pprImm imm] -+ ppr_item II16 _ _ = [ptext (sLit "\t.short\t") <> pprImm imm] - -- ppr_item II64 (CmmInt x _) = -+ ppr_item II64 (CmmInt x _) dflags -+ | not(archPPC_64 dflags) = - [ptext (sLit "\t.long\t") - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32)), - ptext (sLit "\t.long\t") - <> int (fromIntegral (fromIntegral x :: Word32))] - -- ppr_item _ _ -+ ppr_item _ _ _ - = panic "PPC.Ppr.pprDataItem: no match" - - -@@ -365,6 +425,7 @@ pprInstr (LD sz reg addr) = hcat [ - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" -+ II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" -@@ -393,6 +454,7 @@ pprInstr (LA sz reg addr) = hcat [ - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" -+ II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - _ -> panic "PPC.Ppr.pprInstr: no match" -@@ -568,10 +630,14 @@ pprInstr (ADDE reg1 reg2 reg3) = pprLogi - pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) - pprInstr (SUBFC reg1 reg2 reg3) = pprLogic (sLit "subfc") reg1 reg2 (RIReg reg3) - pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) -+pprInstr (MULLD reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mulld") reg1 reg2 ri - pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri -+pprInstr (MULLD reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri - pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri - pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) -+pprInstr (DIVD reg1 reg2 reg3) = pprLogic (sLit "divd") reg1 reg2 (RIReg reg3) - pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) -+pprInstr (DIVDU reg1 reg2 reg3) = pprLogic (sLit "divdu") reg1 reg2 (RIReg reg3) - - pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ - hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), -@@ -582,8 +648,17 @@ pprInstr (MULLW_MayOflo reg1 reg2 reg3) - pprReg reg1, ptext (sLit ", "), - ptext (sLit "2, 31, 31") ] - ] -+pprInstr (MULLD_MayOflo reg1 reg2 reg3) = vcat [ -+ hcat [ ptext (sLit "\tmulldo\t"), pprReg reg1, ptext (sLit ", "), -+ pprReg reg2, ptext (sLit ", "), -+ pprReg reg3 ], -+ hcat [ ptext (sLit "\tmfxer\t"), pprReg reg1 ], -+ hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), -+ pprReg reg1, ptext (sLit ", "), -+ ptext (sLit "2, 31, 31") ] -+ ] - -- -- for some reason, "andi" doesn't exist. -+ -- for some reason, "andi" doesn't exist. - -- we'll use "andi." instead. - pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', -@@ -600,6 +675,17 @@ pprInstr (AND reg1 reg2 ri) = pprLogic ( - pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri - pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri - -+pprInstr (ORIS reg1 reg2 imm) = hcat [ -+ char '\t', -+ ptext (sLit "oris"), -+ char '\t', -+ pprReg reg1, -+ ptext (sLit ", "), -+ pprReg reg2, -+ ptext (sLit ", "), -+ pprImm imm -+ ] -+ - pprInstr (XORIS reg1 reg2 imm) = hcat [ - char '\t', - ptext (sLit "xoris"), -@@ -625,26 +711,40 @@ pprInstr (NEG reg1 reg2) = pprUnary (sLi - pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 - - --pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = -+pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- Handle the case where we are asked to shift a 32 bit register by - -- less than zero or more than 31 bits. We convert this into a clear - -- of the destination register. - -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - --pprInstr (SLW reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = -+pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = - -- As aboce for SR, but for left shifts. - -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870 - pprInstr (XOR reg1 reg2 (RIReg reg2)) - --pprInstr (SRAW reg1 reg2 (RIImm (ImmInt i))) | i > 31 = -- pprInstr (SRAW reg1 reg2 (RIImm (ImmInt 31))) -- --pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) -- --pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) -+pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 = -+ pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) - --pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) -+pprInstr (SL sz reg1 reg2 ri) = -+ let op = case sz of -+ II32 -> "slw" -+ II64 -> "sld" -+ _ -> panic "PPC.Ppr.pprInstr: shift illegal size" -+ in pprLogic (sLit op) reg1 reg2 (limitShiftRI sz ri) -+pprInstr (SR sz reg1 reg2 ri) = -+ let op = case sz of -+ II32 -> "srw" -+ II64 -> "srd" -+ _ -> panic "PPC.Ppr.pprInstr: shift illegal size" -+ in pprLogic (sLit op) reg1 reg2 (limitShiftRI sz ri) -+ -+pprInstr (SRA sz reg1 reg2 ri) = -+ let op = case sz of -+ II32 -> "sraw" -+ II64 -> "srad" -+ _ -> panic "PPC.Ppr.pprInstr: shift illegal size" -+ in pprLogic (sLit op) reg1 reg2 (limitShiftRI sz ri) - pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ - ptext (sLit "\trlwinm\t"), - pprReg reg1, -@@ -676,6 +776,8 @@ pprInstr (FCMP reg1 reg2) = hcat [ - ] - - pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -+pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2 -+pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2 - pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 - - pprInstr (CRNOR dst src1 src2) = hcat [ -@@ -706,6 +808,18 @@ pprInstr (FETCHPC reg) = vcat [ - hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] - ] - -+pprInstr (FETCHTOC reg lab) = vcat [ -+ hcat [ ptext (sLit "0:\taddis\t"), pprReg reg, -+ ptext (sLit ",12,.TOC.-0b@ha") ], -+ hcat [ ptext (sLit "\taddi\t"), pprReg reg, -+ char ',', pprReg reg, -+ ptext (sLit ",.TOC.-0b@l") ], -+ hcat [ ptext (sLit "\t.localentry\t"), -+ ppr lab, -+ ptext (sLit ",.-"), -+ ppr lab] -+ ] -+ - pprInstr LWSYNC = ptext (sLit "\tlwsync") - - pprInstr (UPDATE_SP fmt amount@(ImmInt offset)) -@@ -723,7 +837,7 @@ pprInstr (UPDATE_SP fmt amount) - pprInstr (ADD tmp tmp (RIImm (LO amount))), - pprInstr (STU fmt r0 (AddrRegReg sp tmp)) - ] -- -+pprInstr NOP = ptext (sLit "\tnop") - -- pprInstr _ = panic "pprInstr (ppc)" - - -@@ -777,9 +891,12 @@ pprFSize FF64 = empty - pprFSize FF32 = char 's' - pprFSize _ = panic "PPC.Ppr.pprFSize: no match" - -- -- limit immediate argument for shift instruction to range 0..31 --limitShiftRI :: RI -> RI --limitShiftRI (RIImm (ImmInt i)) | i > 31 || i < 0 = -+ -- limit immediate argument for shift instruction to range 0..63 -+ -- for 64 bit size and 0..32 otherwise -+limitShiftRI :: Size -> RI -> RI -+limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 = - panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed." --limitShiftRI x = x -+limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 = -+ panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed." -+limitShiftRI _ x = x - -Index: ghc-7.10.2.20151114/compiler/nativeGen/PPC/Regs.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/PPC/Regs.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/PPC/Regs.hs -@@ -37,7 +37,7 @@ module PPC.Regs ( - fits16Bits, - makeImmediate, - fReg, -- r0, sp, r3, r4, r27, r28, r30, -+ r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, - tmpReg, - f1, f20, f21, - -@@ -65,8 +65,8 @@ import FastBool - import FastTypes - import Platform - --import Data.Word ( Word8, Word16, Word32 ) --import Data.Int ( Int8, Int16, Int32 ) -+import Data.Word ( Word8, Word16, Word32, Word64 ) -+import Data.Int ( Int8, Int16, Int32, Int64 ) - - - -- squeese functions for the graph allocator ----------------------------------- -@@ -148,6 +148,8 @@ data Imm - | LO Imm - | HI Imm - | HA Imm {- high halfword adjusted -} -+ | HIGHERA Imm -+ | HIGHESTA Imm - - - strImmLit :: String -> Imm -@@ -270,9 +272,11 @@ fits16Bits x = x >= -32768 && x < 32768 - makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm - makeImmediate rep signed x = fmap ImmInt (toI16 rep signed) - where -+ narrow W64 False = fromIntegral (fromIntegral x :: Word64) - narrow W32 False = fromIntegral (fromIntegral x :: Word32) - narrow W16 False = fromIntegral (fromIntegral x :: Word16) - narrow W8 False = fromIntegral (fromIntegral x :: Word8) -+ narrow W64 True = fromIntegral (fromIntegral x :: Int64) - narrow W32 True = fromIntegral (fromIntegral x :: Int32) - narrow W16 True = fromIntegral (fromIntegral x :: Int16) - narrow W8 True = fromIntegral (fromIntegral x :: Int8) -@@ -286,6 +290,12 @@ makeImmediate rep signed x = fmap ImmInt - toI16 W32 False - | narrowed >= 0 && narrowed < 65536 = Just narrowed - | otherwise = Nothing -+ toI16 W64 True -+ | narrowed >= -32768 && narrowed < 32768 = Just narrowed -+ | otherwise = Nothing -+ toI16 W64 False -+ | narrowed >= 0 && narrowed < 65536 = Just narrowed -+ | otherwise = Nothing - toI16 _ _ = Just narrowed - - -@@ -297,11 +307,14 @@ point registers. - fReg :: Int -> RegNo - fReg x = (32 + x) - --r0, sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg -+r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg - r0 = regSingle 0 - sp = regSingle 1 -+toc = regSingle 2 - r3 = regSingle 3 - r4 = regSingle 4 -+r11 = regSingle 11 -+r12 = regSingle 12 - r27 = regSingle 27 - r28 = regSingle 28 - r30 = regSingle 30 -Index: ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs -@@ -111,7 +111,7 @@ trivColorable platform virtualRegSqueeze - ArchX86_64 -> 5 - ArchPPC -> 16 - ArchSPARC -> 14 -- ArchPPC_64 -> panic "trivColorable ArchPPC_64" -+ ArchPPC_64 _ -> panic "trivColorable ArchPPC_64" - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" -@@ -136,7 +136,7 @@ trivColorable platform virtualRegSqueeze - ArchX86_64 -> 0 - ArchPPC -> 0 - ArchSPARC -> 22 -- ArchPPC_64 -> panic "trivColorable ArchPPC_64" -+ ArchPPC_64 _ -> panic "trivColorable ArchPPC_64" - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" -@@ -161,7 +161,7 @@ trivColorable platform virtualRegSqueeze - ArchX86_64 -> 0 - ArchPPC -> 26 - ArchSPARC -> 11 -- ArchPPC_64 -> panic "trivColorable ArchPPC_64" -+ ArchPPC_64 _ -> panic "trivColorable ArchPPC_64" - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" -@@ -186,7 +186,7 @@ trivColorable platform virtualRegSqueeze - ArchX86_64 -> 10 - ArchPPC -> 0 - ArchSPARC -> 0 -- ArchPPC_64 -> panic "trivColorable ArchPPC_64" -+ ArchPPC_64 _ -> panic "trivColorable ArchPPC_64" - ArchARM _ _ _ -> panic "trivColorable ArchARM" - ArchARM64 -> panic "trivColorable ArchARM64" - ArchAlpha -> panic "trivColorable ArchAlpha" -Index: ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs -@@ -76,7 +76,7 @@ maxSpillSlots dflags - ArchSPARC -> SPARC.Instr.maxSpillSlots dflags - ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" - ArchARM64 -> panic "maxSpillSlots ArchARM64" -- ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" -+ ArchPPC_64 _ -> PPC.Instr.maxSpillSlots dflags - ArchAlpha -> panic "maxSpillSlots ArchAlpha" - ArchMipseb -> panic "maxSpillSlots ArchMipseb" - ArchMipsel -> panic "maxSpillSlots ArchMipsel" -Index: ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Linear/Main.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/RegAlloc/Linear/Main.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/RegAlloc/Linear/Main.hs -@@ -211,7 +211,7 @@ linearRegAlloc dflags entry_ids block_li - ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchARM64 -> panic "linearRegAlloc ArchARM64" -- ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" -+ ArchPPC_64 _ -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" -Index: ghc-7.10.2.20151114/compiler/nativeGen/TargetReg.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/nativeGen/TargetReg.hs -+++ ghc-7.10.2.20151114/compiler/nativeGen/TargetReg.hs -@@ -44,7 +44,7 @@ targetVirtualRegSqueeze platform - ArchX86_64 -> X86.virtualRegSqueeze - ArchPPC -> PPC.virtualRegSqueeze - ArchSPARC -> SPARC.virtualRegSqueeze -- ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" -+ ArchPPC_64 _ -> PPC.virtualRegSqueeze - ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" - ArchARM64 -> panic "targetVirtualRegSqueeze ArchARM64" - ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" -@@ -61,7 +61,7 @@ targetRealRegSqueeze platform - ArchX86_64 -> X86.realRegSqueeze - ArchPPC -> PPC.realRegSqueeze - ArchSPARC -> SPARC.realRegSqueeze -- ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" -+ ArchPPC_64 _ -> PPC.realRegSqueeze - ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" - ArchARM64 -> panic "targetRealRegSqueeze ArchARM64" - ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" -@@ -77,7 +77,7 @@ targetClassOfRealReg platform - ArchX86_64 -> X86.classOfRealReg platform - ArchPPC -> PPC.classOfRealReg - ArchSPARC -> SPARC.classOfRealReg -- ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" -+ ArchPPC_64 _ -> PPC.classOfRealReg - ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" - ArchARM64 -> panic "targetClassOfRealReg ArchARM64" - ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" -@@ -93,7 +93,7 @@ targetMkVirtualReg platform - ArchX86_64 -> X86.mkVirtualReg - ArchPPC -> PPC.mkVirtualReg - ArchSPARC -> SPARC.mkVirtualReg -- ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" -+ ArchPPC_64 _ -> PPC.mkVirtualReg - ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" - ArchARM64 -> panic "targetMkVirtualReg ArchARM64" - ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" -@@ -109,7 +109,7 @@ targetRegDotColor platform - ArchX86_64 -> X86.regDotColor platform - ArchPPC -> PPC.regDotColor - ArchSPARC -> SPARC.regDotColor -- ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" -+ ArchPPC_64 _ -> PPC.regDotColor - ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" - ArchARM64 -> panic "targetRegDotColor ArchARM64" - ArchAlpha -> panic "targetRegDotColor ArchAlpha" -Index: ghc-7.10.2.20151114/compiler/utils/Platform.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/compiler/utils/Platform.hs -+++ ghc-7.10.2.20151114/compiler/utils/Platform.hs -@@ -8,6 +8,7 @@ module Platform ( - ArmISA(..), - ArmISAExt(..), - ArmABI(..), -+ PPC_64ABI(..), - - target32Bit, - isARM, -@@ -47,6 +48,8 @@ data Arch - | ArchX86_64 - | ArchPPC - | ArchPPC_64 -+ { ppc_64ABI :: PPC_64ABI -+ } - | ArchSPARC - | ArchARM - { armISA :: ArmISA -@@ -107,10 +110,18 @@ data ArmABI - | HARD - deriving (Read, Show, Eq) - -+-- | PowerPC 64-bit ABI -+-- -+data PPC_64ABI -+ = ELF_V1 -+ | ELF_V2 -+ deriving (Read, Show, Eq) -+ -+-- | This predicate tells us whether the platform is 32-bit. - target32Bit :: Platform -> Bool - target32Bit p = platformWordSize p == 4 - ---- | This predicates tells us whether the OS supports ELF-like shared libraries. -+-- | This predicate tells us whether the OS supports ELF-like shared libraries. - osElfTarget :: OS -> Bool - osElfTarget OSLinux = True - osElfTarget OSFreeBSD = True -Index: ghc-7.10.2.20151114/configure.ac -=================================================================== ---- ghc-7.10.2.20151114.orig/configure.ac -+++ ghc-7.10.2.20151114/configure.ac -@@ -240,7 +240,7 @@ AC_SUBST(SOLARIS_BROKEN_SHLD) - dnl ** Do an unregisterised build? - dnl -------------------------------------------------------------- - case "$HostArch" in -- i386|x86_64|powerpc|arm) -+ i386|x86_64|powerpc|powerpc64|powerpc64le|arm) - UnregisterisedDefault=NO - ;; - *) -Index: ghc-7.10.2.20151114/includes/CodeGen.Platform.hs -=================================================================== ---- ghc-7.10.2.20151114.orig/includes/CodeGen.Platform.hs -+++ ghc-7.10.2.20151114/includes/CodeGen.Platform.hs -@@ -884,6 +884,9 @@ freeReg 1 = fastBool False -- The Stack - # if !MACHREGS_darwin - -- most non-darwin powerpc OSes use r2 as a TOC pointer or something like that - freeReg 2 = fastBool False -+-- TODO: make this conditonal for ppc64 ELF -+freeReg 13 = fastBool False -- reserved for system thread ID -+-- TODO: do not reserve r30 in ppc64 ELF - -- at least linux in -fPIC relies on r30 in PLT stubs - freeReg 30 = fastBool False - # endif -Index: ghc-7.10.2.20151114/includes/stg/HaskellMachRegs.h -=================================================================== ---- ghc-7.10.2.20151114.orig/includes/stg/HaskellMachRegs.h -+++ ghc-7.10.2.20151114/includes/stg/HaskellMachRegs.h -@@ -35,7 +35,8 @@ - - #define MACHREGS_i386 i386_TARGET_ARCH - #define MACHREGS_x86_64 x86_64_TARGET_ARCH --#define MACHREGS_powerpc (powerpc_TARGET_ARCH || powerpc64_TARGET_ARCH || rs6000_TARGET_ARCH) -+#define MACHREGS_powerpc (powerpc_TARGET_ARCH || powerpc64_TARGET_ARCH \ -+ || powerpc64le_TARGET_ARCH || rs6000_TARGET_ARCH) - #define MACHREGS_sparc sparc_TARGET_ARCH - #define MACHREGS_arm arm_TARGET_ARCH - #define MACHREGS_aarch64 aarch64_TARGET_ARCH -Index: ghc-7.10.2.20151114/includes/stg/RtsMachRegs.h -=================================================================== ---- ghc-7.10.2.20151114.orig/includes/stg/RtsMachRegs.h -+++ ghc-7.10.2.20151114/includes/stg/RtsMachRegs.h -@@ -41,7 +41,8 @@ - - #define MACHREGS_i386 i386_HOST_ARCH - #define MACHREGS_x86_64 x86_64_HOST_ARCH --#define MACHREGS_powerpc (powerpc_HOST_ARCH || powerpc64_HOST_ARCH || rs6000_HOST_ARCH) -+#define MACHREGS_powerpc (powerpc_HOST_ARCH || powerpc64_HOST_ARCH \ -+ || powerpc64le_HOST_ARCH || rs6000_HOST_ARCH) - #define MACHREGS_sparc sparc_HOST_ARCH - #define MACHREGS_arm arm_HOST_ARCH - #define MACHREGS_aarch64 aarch64_HOST_ARCH -Index: ghc-7.10.2.20151114/includes/stg/SMP.h -=================================================================== ---- ghc-7.10.2.20151114.orig/includes/stg/SMP.h -+++ ghc-7.10.2.20151114/includes/stg/SMP.h -@@ -127,6 +127,14 @@ xchg(StgPtr p, StgWord w) - :"=&r" (result) - :"r" (w), "r" (p) - ); -+#elif powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ __asm__ __volatile__ ( -+ "1: ldarx %0, 0, %2\n" -+ " stdcx. %1, 0, %2\n" -+ " bne- 1b" -+ :"=&r" (result) -+ :"r" (w), "r" (p) -+ ); - #elif sparc_HOST_ARCH - result = w; - __asm__ __volatile__ ( -@@ -208,6 +216,20 @@ cas(StgVolatilePtr p, StgWord o, StgWord - :"cc", "memory" - ); - return result; -+#elif powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ StgWord result; -+ __asm__ __volatile__ ( -+ "1: ldarx %0, 0, %3\n" -+ " cmpd %0, %1\n" -+ " bne 2f\n" -+ " stdcx. %2, 0, %3\n" -+ " bne- 1b\n" -+ "2:" -+ :"=&r" (result) -+ :"r" (o), "r" (n), "r" (p) -+ :"cc", "memory" -+ ); -+ return result; - #elif sparc_HOST_ARCH - __asm__ __volatile__ ( - "cas [%1], %2, %0" -@@ -345,7 +367,7 @@ write_barrier(void) { - return; - #elif i386_HOST_ARCH || x86_64_HOST_ARCH - __asm__ __volatile__ ("" : : : "memory"); --#elif powerpc_HOST_ARCH -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH - __asm__ __volatile__ ("lwsync" : : : "memory"); - #elif sparc_HOST_ARCH - /* Sparc in TSO mode does not require store/store barriers. */ -@@ -367,7 +389,7 @@ store_load_barrier(void) { - __asm__ __volatile__ ("lock; addl $0,0(%%esp)" : : : "memory"); - #elif x86_64_HOST_ARCH - __asm__ __volatile__ ("lock; addq $0,0(%%rsp)" : : : "memory"); --#elif powerpc_HOST_ARCH -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH - __asm__ __volatile__ ("sync" : : : "memory"); - #elif sparc_HOST_ARCH - __asm__ __volatile__ ("membar #StoreLoad" : : : "memory"); -@@ -390,7 +412,7 @@ load_load_barrier(void) { - __asm__ __volatile__ ("" : : : "memory"); - #elif x86_64_HOST_ARCH - __asm__ __volatile__ ("" : : : "memory"); --#elif powerpc_HOST_ARCH -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH - __asm__ __volatile__ ("lwsync" : : : "memory"); - #elif sparc_HOST_ARCH - /* Sparc in TSO mode does not require load/load barriers. */ -Index: ghc-7.10.2.20151114/mk/config.mk.in -=================================================================== ---- ghc-7.10.2.20151114.orig/mk/config.mk.in -+++ ghc-7.10.2.20151114/mk/config.mk.in -@@ -159,9 +159,9 @@ GhcUnregisterised=@Unregisterised@ - # (as well as a C backend) - # - # Target platforms supported: --# i386, powerpc -+# i386, powerpc, powerpc64, sparc - # IOS and AIX are not supported --ArchSupportsNCG=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc sparc))) -+ArchSupportsNCG=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc powerpc64 powerpc64le sparc))) - OsSupportsNCG=$(strip $(patsubst $(TargetOS_CPP), YES, $(patsubst ios,,$(patsubst aix,,$(TargetOS_CPP))))) - - GhcWithNativeCodeGen := $(strip\ -@@ -172,7 +172,7 @@ HaveLibDL = @HaveLibDL@ - - # ArchSupportsSMP should be set iff there is support for that arch in - # includes/stg/SMP.h --ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc arm aarch64))) -+ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc powerpc64 powerpc64le arm aarch64))) - - GhcWithSMP := $(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO)) - -@@ -180,7 +180,7 @@ GhcWithSMP := $(strip $(if $(filter YESN - # has support for this OS/ARCH combination. - - OsSupportsGHCi=$(strip $(patsubst $(TargetOS_CPP), YES, $(findstring $(TargetOS_CPP), mingw32 cygwin32 linux solaris2 freebsd dragonfly netbsd openbsd darwin kfreebsdgnu))) --ArchSupportsGHCi=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc sparc sparc64 arm aarch64))) -+ArchSupportsGHCi=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 powerpc powerpc64 powerpc64le sparc sparc64 arm aarch64))) - - ifeq "$(OsSupportsGHCi)$(ArchSupportsGHCi)" "YESYES" - GhcWithInterpreter=YES -@@ -193,7 +193,7 @@ endif - # (see TABLES_NEXT_TO_CODE in the RTS). Whether we actually compile for - # TABLES_NEXT_TO_CODE depends on whether we're building unregisterised - # code or not, which may be decided by options to the compiler later. --ifneq "$(findstring $(TargetArch_CPP)X, ia64X powerpc64X)" "" -+ifneq "$(findstring $(TargetArch_CPP)X, ia64X powerpc64X powerpc64leX)" "" - GhcEnableTablesNextToCode=NO - else - GhcEnableTablesNextToCode=YES -Index: ghc-7.10.2.20151114/rts/StgCRun.c -=================================================================== ---- ghc-7.10.2.20151114.orig/rts/StgCRun.c -+++ ghc-7.10.2.20151114/rts/StgCRun.c -@@ -662,11 +662,19 @@ StgRunIsImplementedInAssembler(void) - } - - #else // linux_HOST_OS --#error Only linux support for power64 right now. -+#error Only Linux support for power64 right now. - #endif - - #endif - -+#ifdef powerpc64le_HOST_ARCH -+/* ----------------------------------------------------------------------------- -+ PowerPC 64 little endian architecture -+ -+ Really everything is in assembler, so we don't have to deal with GCC... -+ -------------------------------------------------------------------------- */ -+#endif -+ - /* ----------------------------------------------------------------------------- - ARM architecture - -------------------------------------------------------------------------- */ -Index: ghc-7.10.2.20151114/rts/StgCRunAsm.S -=================================================================== ---- /dev/null -+++ ghc-7.10.2.20151114/rts/StgCRunAsm.S -@@ -0,0 +1,114 @@ -+#include "ghcconfig.h" -+#include "rts/Constants.h" -+#ifdef powerpc64le_HOST_ARCH -+#ifdef linux_HOST_OS -+#define STACK_FRAME_SIZE RESERVED_C_STACK_BYTES+304 -+ .file "StgCRun.c" -+ .abiversion 2 -+ .section ".toc","aw" -+ .section ".text" -+ .align 2 -+.globl StgRun -+.hidden StgRun -+.type StgRun,@function -+StgRun: -+.localentry StgRun,.-StgRun -+ mflr 0 -+ mr 5, 1 -+ std 0, 16(1) -+ stdu 1, -(STACK_FRAME_SIZE)(1) -+ std 2, -296(5) -+ std 14, -288(5) -+ std 15, -280(5) -+ std 16, -272(5) -+ std 17, -264(5) -+ std 18, -256(5) -+ std 19, -248(5) -+ std 20, -240(5) -+ std 21, -232(5) -+ std 22, -224(5) -+ std 23, -216(5) -+ std 24, -208(5) -+ std 25, -200(5) -+ std 26, -192(5) -+ std 27, -184(5) -+ std 28, -176(5) -+ std 29, -168(5) -+ std 30, -160(5) -+ std 31, -152(5) -+ stfd 14, -144(5) -+ stfd 15, -136(5) -+ stfd 16, -128(5) -+ stfd 17, -120(5) -+ stfd 18, -112(5) -+ stfd 19, -104(5) -+ stfd 20, -96(5) -+ stfd 21, -88(5) -+ stfd 22, -80(5) -+ stfd 23, -72(5) -+ stfd 24, -64(5) -+ stfd 25, -56(5) -+ stfd 26, -48(5) -+ stfd 27, -40(5) -+ stfd 28, -32(5) -+ stfd 29, -24(5) -+ stfd 30, -16(5) -+ stfd 31, -8(5) -+ mr 27, 4 -+ mtctr 3 -+ mr 12, 3 -+ bctr -+.globl StgReturn -+.type StgReturn,@function -+StgReturn: -+.localentry StgReturn,.-StgReturn -+ mr 3,14 -+ la 5, STACK_FRAME_SIZE(1) -+ ld 2, -296(5) -+ ld 14, -288(5) -+ ld 15, -280(5) -+ ld 16, -272(5) -+ ld 17, -264(5) -+ ld 18, -256(5) -+ ld 19, -248(5) -+ ld 20, -240(5) -+ ld 21, -232(5) -+ ld 22, -224(5) -+ ld 23, -216(5) -+ ld 24, -208(5) -+ ld 25, -200(5) -+ ld 26, -192(5) -+ ld 27, -184(5) -+ ld 28, -176(5) -+ ld 29, -168(5) -+ ld 30, -160(5) -+ ld 31, -152(5) -+ lfd 14, -144(5) -+ lfd 15, -136(5) -+ lfd 16, -128(5) -+ lfd 17, -120(5) -+ lfd 18, -112(5) -+ lfd 19, -104(5) -+ lfd 20, -96(5) -+ lfd 21, -88(5) -+ lfd 22, -80(5) -+ lfd 23, -72(5) -+ lfd 24, -64(5) -+ lfd 25, -56(5) -+ lfd 26, -48(5) -+ lfd 27, -40(5) -+ lfd 28, -32(5) -+ lfd 29, -24(5) -+ lfd 30, -16(5) -+ lfd 31, -8(5) -+ mr 1, 5 -+ ld 0, 16(1) -+ mtlr 0 -+ blr -+ -+ .section .note.GNU-stack,"",@progbits -+#else // linux_HOST_OS -+#error Only Linux support for power64 little endian right now. -+#endif -+ -+#endif -Index: ghc-7.10.2.20151114/rts/ghc.mk -=================================================================== ---- ghc-7.10.2.20151114.orig/rts/ghc.mk -+++ ghc-7.10.2.20151114/rts/ghc.mk -@@ -45,6 +45,9 @@ ifneq "$(PORTING_HOST)" "YES" - ifneq "$(findstring $(TargetArch_CPP), i386 powerpc powerpc64)" "" - rts_S_SRCS += rts/AdjustorAsm.S - endif -+ifneq "$(findstring $(TargetArch_CPP), powerpc64le)" "" -+rts_S_SRCS += rts/StgCRunAsm.S -+endif - endif - - ifeq "$(GhcUnregisterised)" "YES" diff --git a/0001-link-command-line-libs-to-temp-so.patch b/0001-link-command-line-libs-to-temp-so.patch deleted file mode 100644 index fa35a1a..0000000 --- a/0001-link-command-line-libs-to-temp-so.patch +++ /dev/null @@ -1,58 +0,0 @@ -From 4177e22ecf45b33758d19780dbf4ab32fed6cbac Mon Sep 17 00:00:00 2001 -From: Peter Trommler -Date: Mon, 14 Dec 2015 19:16:22 +0100 -Subject: [PATCH 1/1] link command line libs to temp so - -Symbols in libraries specified on the GHCis command line are -not available to compiled modules because shared libraries -are loaded with local scope. So we link all libraries specified -on the command line into each temporary shared library. ---- - compiler/ghci/Linker.hs | 15 ++++++++++++++- - 1 file changed, 14 insertions(+), 1 deletion(-) - -Index: ghc-7.10.3/compiler/ghci/Linker.hs -=================================================================== ---- ghc-7.10.3.orig/compiler/ghci/Linker.hs -+++ ghc-7.10.3/compiler/ghci/Linker.hs -@@ -818,11 +818,14 @@ dynLoadObjs :: DynFlags -> PersistentLin - dynLoadObjs _ pls [] = return pls - dynLoadObjs dflags pls objs = do - let platform = targetPlatform dflags -+ let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] -+ let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] - (soFile, libPath , libName) <- newTempLibName dflags (soExt platform) - let -- When running TH for a non-dynamic way, we still need to make - -- -l flags to link against the dynamic libraries, so we turn - -- Opt_Static off - dflags1 = gopt_unset dflags Opt_Static -+ - dflags2 = dflags1 { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want -@@ -838,7 +841,16 @@ dynLoadObjs dflags pls objs = do - , Option ("-Wl," ++ lp) - , Option ("-l" ++ l) - ]) -- (temp_sos pls), -+ (temp_sos pls) -+ ++ concatMap -+ (\lp -> -+ [ Option ("-L" ++ lp) -+ , Option ("-Wl,-rpath") -+ , Option ("-Wl," ++ lp) -+ ]) -+ minus_big_ls -+ ++ map (\l -> Option ("-l" ++ l)) minus_ls, -+ -- add -l options and -L options from dflags - -- Even if we're e.g. profiling, we still want - -- the vanilla dynamic libraries, so we set the - -- ways / build tag to be just WayDyn. -@@ -1031,6 +1043,7 @@ data LibrarySpec - - | Framework String -- Only used for darwin, but does no harm - -+ - -- If this package is already part of the GHCi binary, we'll already - -- have the right DLLs for this package loaded, so don't try to - -- load them again. diff --git a/D2214.patch b/D2214.patch deleted file mode 100644 index 0667cea..0000000 --- a/D2214.patch +++ /dev/null @@ -1,16 +0,0 @@ -Index: ghc-7.10.3/compiler/nativeGen/PPC/Ppr.hs -=================================================================== ---- ghc-7.10.3.orig/compiler/nativeGen/PPC/Ppr.hs -+++ ghc-7.10.3/compiler/nativeGen/PPC/Ppr.hs -@@ -488,9 +488,10 @@ pprInstr (STU sz reg addr) = hcat [ - char '\t', - ptext (sLit "st"), - pprSize sz, -- ptext (sLit "u\t"), -+ char 'u', - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', -+ char '\t', - pprReg reg, - ptext (sLit ", "), - pprAddr addr diff --git a/D2225.patch b/D2225.patch deleted file mode 100644 index 0bbb0a1..0000000 --- a/D2225.patch +++ /dev/null @@ -1,92 +0,0 @@ -Index: ghc-7.10.3/includes/stg/SMP.h -=================================================================== ---- ghc-7.10.3.orig/includes/stg/SMP.h -+++ ghc-7.10.3/includes/stg/SMP.h -@@ -119,22 +119,8 @@ xchg(StgPtr p, StgWord w) - :"+r" (result), "+m" (*p) - : /* no input-only operands */ - ); --#elif powerpc_HOST_ARCH -- __asm__ __volatile__ ( -- "1: lwarx %0, 0, %2\n" -- " stwcx. %1, 0, %2\n" -- " bne- 1b" -- :"=&r" (result) -- :"r" (w), "r" (p) -- ); --#elif powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -- __asm__ __volatile__ ( -- "1: ldarx %0, 0, %2\n" -- " stdcx. %1, 0, %2\n" -- " bne- 1b" -- :"=&r" (result) -- :"r" (w), "r" (p) -- ); -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ result = __sync_lock_test_and_set(p, w); - #elif sparc_HOST_ARCH - result = w; - __asm__ __volatile__ ( -@@ -202,34 +188,8 @@ cas(StgVolatilePtr p, StgWord o, StgWord - :"=a"(o), "+m" (*(volatile unsigned int *)p) - :"0" (o), "r" (n)); - return o; --#elif powerpc_HOST_ARCH -- StgWord result; -- __asm__ __volatile__ ( -- "1: lwarx %0, 0, %3\n" -- " cmpw %0, %1\n" -- " bne 2f\n" -- " stwcx. %2, 0, %3\n" -- " bne- 1b\n" -- "2:" -- :"=&r" (result) -- :"r" (o), "r" (n), "r" (p) -- :"cc", "memory" -- ); -- return result; --#elif powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -- StgWord result; -- __asm__ __volatile__ ( -- "1: ldarx %0, 0, %3\n" -- " cmpd %0, %1\n" -- " bne 2f\n" -- " stdcx. %2, 0, %3\n" -- " bne- 1b\n" -- "2:" -- :"=&r" (result) -- :"r" (o), "r" (n), "r" (p) -- :"cc", "memory" -- ); -- return result; -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ return __sync_val_compare_and_swap(p, o, n); - #elif sparc_HOST_ARCH - __asm__ __volatile__ ( - "cas [%1], %2, %0" -@@ -290,6 +250,7 @@ cas(StgVolatilePtr p, StgWord o, StgWord - - // RRN: Generalized to arbitrary increments to enable fetch-and-add in - // Haskell code (fetchAddIntArray#). -+// PT: add-and-fetch, returns new value - EXTERN_INLINE StgWord - atomic_inc(StgVolatilePtr p, StgWord incr) - { -@@ -301,6 +262,8 @@ atomic_inc(StgVolatilePtr p, StgWord inc - "+r" (r), "+m" (*p): - ); - return r + incr; -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ return __sync_add_and_fetch(p, incr); - #else - StgWord old, new_; - do { -@@ -322,6 +285,8 @@ atomic_dec(StgVolatilePtr p) - "+r" (r), "+m" (*p): - ); - return r-1; -+#elif powerpc_HOST_ARCH || powerpc64_HOST_ARCH || powerpc64le_HOST_ARCH -+ return __sync_sub_and_fetch(p, (StgWord) 1); - #else - StgWord old, new_; - do { diff --git a/atomic-cast.patch b/atomic-cast.patch deleted file mode 100644 index 2130ea1..0000000 --- a/atomic-cast.patch +++ /dev/null @@ -1,546 +0,0 @@ -From e3d2bab86fc89113f8ee65800fdfac81d8d54851 Mon Sep 17 00:00:00 2001 -From: Andreas Schwab -Date: Fri, 2 Oct 2015 23:03:12 +0200 -Subject: [PATCH] Fix signature of atomic builtins - -This patch is due to Andreas Schwab. - -This fixes #10926, which reports (on AArch64) errors of the form, - -``` -/tmp/ghc1492_0/ghc_1.hc:2844:25: warning: passing argument 1 of -'hs_atomic_xor64' makes pointer from integer without a cast -[-Wint-conversion] - _c1Ho = hs_atomic_xor64((*Sp) + (((Sp[1]) << 0x3UL) + 0x10UL), Sp[2]); - ^ - -In file included from -/home/abuild/rpmbuild/BUILD/ghc-7.10.2/includes/Stg.h:273:0: 0, - from /tmp/ghc1492_0/ghc_1.hc:3: - -/home/abuild/rpmbuild/BUILD/ghc-7.10.2/includes/stg/Prim.h:41:11: - note: expected 'volatile StgWord64 * - {aka volatile long unsigned int *}' - but argument is of type 'long unsigned int' - StgWord64 hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val); - ^ -``` - -Test Plan: Validate - -Reviewers: austin, simonmar - -Reviewed By: simonmar - -Subscribers: thomie - -Differential Revision: https://phabricator.haskell.org/D1300 - -GHC Trac Issues: #10926 ---- - includes/stg/Prim.h | 72 ++++++------ - libraries/ghc-prim/cbits/atomic.c | 224 +++++++++++++++++++------------------- - 2 files changed, 148 insertions(+), 148 deletions(-) - -Index: ghc-7.10.2.20151105/includes/stg/Prim.h -=================================================================== ---- ghc-7.10.2.20151105.orig/includes/stg/Prim.h -+++ ghc-7.10.2.20151105/includes/stg/Prim.h -@@ -15,42 +15,42 @@ - #define PRIM_H - - /* libraries/ghc-prim/cbits/atomic.c */ --StgWord hs_atomic_add8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_add16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_add32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_add64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_atomic_sub8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_sub16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_sub32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_atomic_and8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_and16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_and32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_and64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_atomic_nand8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_nand16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_nand32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_atomic_or8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_or16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_or32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_or64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_atomic_xor8(volatile StgWord8 *x, StgWord val); --StgWord hs_atomic_xor16(volatile StgWord16 *x, StgWord val); --StgWord hs_atomic_xor32(volatile StgWord32 *x, StgWord val); --StgWord64 hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val); --StgWord hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new_); --StgWord hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new_); --StgWord hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new_); --StgWord hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new_); --StgWord hs_atomicread8(volatile StgWord8 *x); --StgWord hs_atomicread16(volatile StgWord16 *x); --StgWord hs_atomicread32(volatile StgWord32 *x); --StgWord64 hs_atomicread64(volatile StgWord64 *x); --void hs_atomicwrite8(volatile StgWord8 *x, StgWord val); --void hs_atomicwrite16(volatile StgWord16 *x, StgWord val); --void hs_atomicwrite32(volatile StgWord32 *x, StgWord val); --void hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val); -+StgWord hs_atomic_add8(StgWord x, StgWord val); -+StgWord hs_atomic_add16(StgWord x, StgWord val); -+StgWord hs_atomic_add32(StgWord x, StgWord val); -+StgWord64 hs_atomic_add64(StgWord x, StgWord64 val); -+StgWord hs_atomic_sub8(StgWord x, StgWord val); -+StgWord hs_atomic_sub16(StgWord x, StgWord val); -+StgWord hs_atomic_sub32(StgWord x, StgWord val); -+StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val); -+StgWord hs_atomic_and8(StgWord x, StgWord val); -+StgWord hs_atomic_and16(StgWord x, StgWord val); -+StgWord hs_atomic_and32(StgWord x, StgWord val); -+StgWord64 hs_atomic_and64(StgWord x, StgWord64 val); -+StgWord hs_atomic_nand8(StgWord x, StgWord val); -+StgWord hs_atomic_nand16(StgWord x, StgWord val); -+StgWord hs_atomic_nand32(StgWord x, StgWord val); -+StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val); -+StgWord hs_atomic_or8(StgWord x, StgWord val); -+StgWord hs_atomic_or16(StgWord x, StgWord val); -+StgWord hs_atomic_or32(StgWord x, StgWord val); -+StgWord64 hs_atomic_or64(StgWord x, StgWord64 val); -+StgWord hs_atomic_xor8(StgWord x, StgWord val); -+StgWord hs_atomic_xor16(StgWord x, StgWord val); -+StgWord hs_atomic_xor32(StgWord x, StgWord val); -+StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val); -+StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new_); -+StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new_); -+StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new_); -+StgWord hs_cmpxchg64(StgWord64 x, StgWord64 old, StgWord64 new_); -+StgWord hs_atomicread8(StgWord x); -+StgWord hs_atomicread16(StgWord x); -+StgWord hs_atomicread32(StgWord x); -+StgWord64 hs_atomicread64(StgWord x); -+void hs_atomicwrite8(StgWord x, StgWord val); -+void hs_atomicwrite16(StgWord x, StgWord val); -+void hs_atomicwrite32(StgWord x, StgWord val); -+void hs_atomicwrite64(StgWord x, StgWord64 val); - - /* libraries/ghc-prim/cbits/bswap.c */ - StgWord16 hs_bswap16(StgWord16 x); -Index: ghc-7.10.2.20151105/libraries/ghc-prim/cbits/atomic.c -=================================================================== ---- ghc-7.10.2.20151105.orig/libraries/ghc-prim/cbits/atomic.c -+++ ghc-7.10.2.20151105/libraries/ghc-prim/cbits/atomic.c -@@ -11,97 +11,97 @@ - - // FetchAddByteArrayOp_Int - --extern StgWord hs_atomic_add8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_add8(StgWord x, StgWord val); - StgWord --hs_atomic_add8(volatile StgWord8 *x, StgWord val) -+hs_atomic_add8(StgWord x, StgWord val) - { -- return __sync_fetch_and_add(x, (StgWord8) val); -+ return __sync_fetch_and_add((volatile StgWord8 *) x, (StgWord8) val); - } - --extern StgWord hs_atomic_add16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_add16(StgWord x, StgWord val); - StgWord --hs_atomic_add16(volatile StgWord16 *x, StgWord val) -+hs_atomic_add16(StgWord x, StgWord val) - { -- return __sync_fetch_and_add(x, (StgWord16) val); -+ return __sync_fetch_and_add((volatile StgWord16 *) x, (StgWord16) val); - } - --extern StgWord hs_atomic_add32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_add32(StgWord x, StgWord val); - StgWord --hs_atomic_add32(volatile StgWord32 *x, StgWord val) -+hs_atomic_add32(StgWord x, StgWord val) - { -- return __sync_fetch_and_add(x, (StgWord32) val); -+ return __sync_fetch_and_add((volatile StgWord32 *) x, (StgWord32) val); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_add64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_add64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_add64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_add64(StgWord x, StgWord64 val) - { -- return __sync_fetch_and_add(x, val); -+ return __sync_fetch_and_add((volatile StgWord64 *) x, val); - } - #endif - - // FetchSubByteArrayOp_Int - --extern StgWord hs_atomic_sub8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_sub8(StgWord x, StgWord val); - StgWord --hs_atomic_sub8(volatile StgWord8 *x, StgWord val) -+hs_atomic_sub8(StgWord x, StgWord val) - { -- return __sync_fetch_and_sub(x, (StgWord8) val); -+ return __sync_fetch_and_sub((volatile StgWord8 *) x, (StgWord8) val); - } - --extern StgWord hs_atomic_sub16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_sub16(StgWord x, StgWord val); - StgWord --hs_atomic_sub16(volatile StgWord16 *x, StgWord val) -+hs_atomic_sub16(StgWord x, StgWord val) - { -- return __sync_fetch_and_sub(x, (StgWord16) val); -+ return __sync_fetch_and_sub((volatile StgWord16 *) x, (StgWord16) val); - } - --extern StgWord hs_atomic_sub32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_sub32(StgWord x, StgWord val); - StgWord --hs_atomic_sub32(volatile StgWord32 *x, StgWord val) -+hs_atomic_sub32(StgWord x, StgWord val) - { -- return __sync_fetch_and_sub(x, (StgWord32) val); -+ return __sync_fetch_and_sub((volatile StgWord32 *) x, (StgWord32) val); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_sub64(StgWord x, StgWord64 val) - { -- return __sync_fetch_and_sub(x, val); -+ return __sync_fetch_and_sub((volatile StgWord64 *) x, val); - } - #endif - - // FetchAndByteArrayOp_Int - --extern StgWord hs_atomic_and8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_and8(StgWord x, StgWord val); - StgWord --hs_atomic_and8(volatile StgWord8 *x, StgWord val) -+hs_atomic_and8(StgWord x, StgWord val) - { -- return __sync_fetch_and_and(x, (StgWord8) val); -+ return __sync_fetch_and_and((volatile StgWord8 *) x, (StgWord8) val); - } - --extern StgWord hs_atomic_and16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_and16(StgWord x, StgWord val); - StgWord --hs_atomic_and16(volatile StgWord16 *x, StgWord val) -+hs_atomic_and16(StgWord x, StgWord val) - { -- return __sync_fetch_and_and(x, (StgWord16) val); -+ return __sync_fetch_and_and((volatile StgWord16 *) x, (StgWord16) val); - } - --extern StgWord hs_atomic_and32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_and32(StgWord x, StgWord val); - StgWord --hs_atomic_and32(volatile StgWord32 *x, StgWord val) -+hs_atomic_and32(StgWord x, StgWord val) - { -- return __sync_fetch_and_and(x, (StgWord32) val); -+ return __sync_fetch_and_and((volatile StgWord32 *) x, (StgWord32) val); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_and64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_and64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_and64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_and64(StgWord x, StgWord64 val) - { -- return __sync_fetch_and_and(x, val); -+ return __sync_fetch_and_and((volatile StgWord64 *) x, val); - } - #endif - -@@ -117,204 +117,204 @@ hs_atomic_and64(volatile StgWord64 *x, S - return tmp; \ - } - --extern StgWord hs_atomic_nand8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_nand8(StgWord x, StgWord val); - StgWord --hs_atomic_nand8(volatile StgWord8 *x, StgWord val) -+hs_atomic_nand8(StgWord x, StgWord val) - { - #ifdef __clang__ -- CAS_NAND(x, (StgWord8) val) -+ CAS_NAND((volatile StgWord8 *) x, (StgWord8) val) - #else -- return __sync_fetch_and_nand(x, (StgWord8) val); -+ return __sync_fetch_and_nand((volatile StgWord8 *) x, (StgWord8) val); - #endif - } - --extern StgWord hs_atomic_nand16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_nand16(StgWord x, StgWord val); - StgWord --hs_atomic_nand16(volatile StgWord16 *x, StgWord val) -+hs_atomic_nand16(StgWord x, StgWord val) - { - #ifdef __clang__ -- CAS_NAND(x, (StgWord16) val); -+ CAS_NAND((volatile StgWord16 *) x, (StgWord16) val); - #else -- return __sync_fetch_and_nand(x, (StgWord16) val); -+ return __sync_fetch_and_nand((volatile StgWord16 *) x, (StgWord16) val); - #endif - } - --extern StgWord hs_atomic_nand32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_nand32(StgWord x, StgWord val); - StgWord --hs_atomic_nand32(volatile StgWord32 *x, StgWord val) -+hs_atomic_nand32(StgWord x, StgWord val) - { - #ifdef __clang__ -- CAS_NAND(x, (StgWord32) val); -+ CAS_NAND((volatile StgWord32 *) x, (StgWord32) val); - #else -- return __sync_fetch_and_nand(x, (StgWord32) val); -+ return __sync_fetch_and_nand((volatile StgWord32 *) x, (StgWord32) val); - #endif - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_nand64(StgWord x, StgWord64 val) - { - #ifdef __clang__ -- CAS_NAND(x, val); -+ CAS_NAND((volatile StgWord64 *) x, val); - #else -- return __sync_fetch_and_nand(x, val); -+ return __sync_fetch_and_nand((volatile StgWord64 *) x, val); - #endif - } - #endif - - // FetchOrByteArrayOp_Int - --extern StgWord hs_atomic_or8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_or8(StgWord x, StgWord val); - StgWord --hs_atomic_or8(volatile StgWord8 *x, StgWord val) -+hs_atomic_or8(StgWord x, StgWord val) - { -- return __sync_fetch_and_or(x, (StgWord8) val); -+ return __sync_fetch_and_or((volatile StgWord8 *) x, (StgWord8) val); - } - --extern StgWord hs_atomic_or16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_or16(StgWord x, StgWord val); - StgWord --hs_atomic_or16(volatile StgWord16 *x, StgWord val) -+hs_atomic_or16(StgWord x, StgWord val) - { -- return __sync_fetch_and_or(x, (StgWord16) val); -+ return __sync_fetch_and_or((volatile StgWord16 *) x, (StgWord16) val); - } - --extern StgWord hs_atomic_or32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_or32(StgWord x, StgWord val); - StgWord --hs_atomic_or32(volatile StgWord32 *x, StgWord val) -+hs_atomic_or32(StgWord x, StgWord val) - { -- return __sync_fetch_and_or(x, (StgWord32) val); -+ return __sync_fetch_and_or((volatile StgWord32 *) x, (StgWord32) val); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_or64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_or64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_or64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_or64(StgWord x, StgWord64 val) - { -- return __sync_fetch_and_or(x, val); -+ return __sync_fetch_and_or((volatile StgWord64 *) x, val); - } - #endif - - // FetchXorByteArrayOp_Int - --extern StgWord hs_atomic_xor8(volatile StgWord8 *x, StgWord val); -+extern StgWord hs_atomic_xor8(StgWord x, StgWord val); - StgWord --hs_atomic_xor8(volatile StgWord8 *x, StgWord val) -+hs_atomic_xor8(StgWord x, StgWord val) - { -- return __sync_fetch_and_xor(x, (StgWord8) val); -+ return __sync_fetch_and_xor((volatile StgWord8 *) x, (StgWord8) val); - } - --extern StgWord hs_atomic_xor16(volatile StgWord16 *x, StgWord val); -+extern StgWord hs_atomic_xor16(StgWord x, StgWord val); - StgWord --hs_atomic_xor16(volatile StgWord16 *x, StgWord val) -+hs_atomic_xor16(StgWord x, StgWord val) - { -- return __sync_fetch_and_xor(x, (StgWord16) val); -+ return __sync_fetch_and_xor((volatile StgWord16 *) x, (StgWord16) val); - } - --extern StgWord hs_atomic_xor32(volatile StgWord32 *x, StgWord val); -+extern StgWord hs_atomic_xor32(StgWord x, StgWord val); - StgWord --hs_atomic_xor32(volatile StgWord32 *x, StgWord val) -+hs_atomic_xor32(StgWord x, StgWord val) - { -- return __sync_fetch_and_xor(x, (StgWord32) val); -+ return __sync_fetch_and_xor((volatile StgWord32 *) x, (StgWord32) val); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord64 hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val); -+extern StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val); - StgWord64 --hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val) -+hs_atomic_xor64(StgWord x, StgWord64 val) - { -- return __sync_fetch_and_xor(x, val); -+ return __sync_fetch_and_xor((volatile StgWord64 *) x, val); - } - #endif - - // CasByteArrayOp_Int - --extern StgWord hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new); -+extern StgWord hs_cmpxchg8(StgWord x, StgWord old, StgWord new); - StgWord --hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new) -+hs_cmpxchg8(StgWord x, StgWord old, StgWord new) - { -- return __sync_val_compare_and_swap(x, (StgWord8) old, (StgWord8) new); -+ return __sync_val_compare_and_swap((volatile StgWord8 *) x, (StgWord8) old, (StgWord8) new); - } - --extern StgWord hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new); -+extern StgWord hs_cmpxchg16(StgWord x, StgWord old, StgWord new); - StgWord --hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new) -+hs_cmpxchg16(StgWord x, StgWord old, StgWord new) - { -- return __sync_val_compare_and_swap(x, (StgWord16) old, (StgWord16) new); -+ return __sync_val_compare_and_swap((volatile StgWord16 *) x, (StgWord16) old, (StgWord16) new); - } - --extern StgWord hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new); -+extern StgWord hs_cmpxchg32(StgWord x, StgWord old, StgWord new); - StgWord --hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new) -+hs_cmpxchg32(StgWord x, StgWord old, StgWord new) - { -- return __sync_val_compare_and_swap(x, (StgWord32) old, (StgWord32) new); -+ return __sync_val_compare_and_swap((volatile StgWord32 *) x, (StgWord32) old, (StgWord32) new); - } - - #if WORD_SIZE_IN_BITS == 64 --extern StgWord hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new); -+extern StgWord hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new); - StgWord --hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new) -+hs_cmpxchg64(StgWord x, StgWord64 old, StgWord64 new) - { -- return __sync_val_compare_and_swap(x, old, new); -+ return __sync_val_compare_and_swap((volatile StgWord64 *) x, old, new); - } - #endif - - // AtomicReadByteArrayOp_Int - --extern StgWord hs_atomicread8(volatile StgWord8 *x); -+extern StgWord hs_atomicread8(StgWord x); - StgWord --hs_atomicread8(volatile StgWord8 *x) -+hs_atomicread8(StgWord x) - { -- return *x; -+ return *(volatile StgWord8 *) x; - } - --extern StgWord hs_atomicread16(volatile StgWord16 *x); -+extern StgWord hs_atomicread16(StgWord x); - StgWord --hs_atomicread16(volatile StgWord16 *x) -+hs_atomicread16(StgWord x) - { -- return *x; -+ return *(volatile StgWord16 *) x; - } - --extern StgWord hs_atomicread32(volatile StgWord32 *x); -+extern StgWord hs_atomicread32(StgWord x); - StgWord --hs_atomicread32(volatile StgWord32 *x) -+hs_atomicread32(StgWord x) - { -- return *x; -+ return *(volatile StgWord32 *) x; - } - --extern StgWord64 hs_atomicread64(volatile StgWord64 *x); -+extern StgWord64 hs_atomicread64(StgWord x); - StgWord64 --hs_atomicread64(volatile StgWord64 *x) -+hs_atomicread64(StgWord x) - { -- return *x; -+ return *(volatile StgWord64 *) x; - } - - // AtomicWriteByteArrayOp_Int - --extern void hs_atomicwrite8(volatile StgWord8 *x, StgWord val); -+extern void hs_atomicwrite8(StgWord x, StgWord val); - void --hs_atomicwrite8(volatile StgWord8 *x, StgWord val) -+hs_atomicwrite8(StgWord x, StgWord val) - { -- *x = (StgWord8) val; -+ *(volatile StgWord8 *) x = (StgWord8) val; - } - --extern void hs_atomicwrite16(volatile StgWord16 *x, StgWord val); -+extern void hs_atomicwrite16(StgWord x, StgWord val); - void --hs_atomicwrite16(volatile StgWord16 *x, StgWord val) -+hs_atomicwrite16(StgWord x, StgWord val) - { -- *x = (StgWord16) val; -+ *(volatile StgWord16 *) x = (StgWord16) val; - } - --extern void hs_atomicwrite32(volatile StgWord32 *x, StgWord val); -+extern void hs_atomicwrite32(StgWord x, StgWord val); - void --hs_atomicwrite32(volatile StgWord32 *x, StgWord val) -+hs_atomicwrite32(StgWord x, StgWord val) - { -- *x = (StgWord32) val; -+ *(volatile StgWord32 *) x = (StgWord32) val; - } - --extern void hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val); -+extern void hs_atomicwrite64(StgWord x, StgWord64 val); - void --hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val) -+hs_atomicwrite64(StgWord x, StgWord64 val) - { -- *x = (StgWord64) val; -+ *(volatile StgWord64 *) x = (StgWord64) val; - } diff --git a/cabal-show-detail-direct.patch b/cabal-show-detail-direct.patch deleted file mode 100644 index 474cef1..0000000 --- a/cabal-show-detail-direct.patch +++ /dev/null @@ -1,103 +0,0 @@ -commit 3792d212a6f60573ef43dd72088a353725d09461 -Author: Joachim Breitner -Date: Thu Nov 5 11:31:12 2015 +0100 - - test: New mode --show-details=direct - - This mode implements #2911, and allows to connect the test runner - directly to stdout/stdin. This is more reliable in the presence of no - threading, i.e. a work-arond for #2398. - - I make the test suite use this, so that it passes again, despite - printing lots of stuff. Once #2398 is fixed properly, the test suite - should probably be extended to test all the various --show-details - modes. - -Index: ghc/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs -=================================================================== ---- ghc.orig/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs 2015-11-05 12:36:38.385252394 +0100 -+++ ghc/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs 2015-11-05 12:36:38.377252228 +0100 -@@ -1725,7 +1725,7 @@ - -- * Test flags - -- ------------------------------------------------------------ - --data TestShowDetails = Never | Failures | Always | Streaming -+data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Show) - - knownTestShowDetails :: [TestShowDetails] -@@ -1813,7 +1813,8 @@ - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " -- ++ "'streaming': show results of test cases in real time.") -+ ++ "'streaming': show results of test cases in real time." -+ ++ "'direct': send results of test cases in real time; no log file.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (readP_to_E (\_ -> "--show-details flag expects one of " -Index: ghc/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs -=================================================================== ---- ghc.orig/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs 2015-11-05 12:36:38.385252394 +0100 -+++ ghc/libraries/Cabal/Cabal/Distribution/Simple/Test/ExeV10.hs 2015-11-05 12:36:38.377252228 +0100 -@@ -30,7 +30,7 @@ - , getCurrentDirectory, removeDirectoryRecursive ) - import System.Exit ( ExitCode(..) ) - import System.FilePath ( (), (<.>) ) --import System.IO ( hGetContents, hPutStr, stdout ) -+import System.IO ( hGetContents, hPutStr, stdout, stderr ) - - runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo -@@ -63,15 +63,20 @@ - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ PD.testName suite - -- (rOut, wOut) <- createPipe -+ (wOut, wErr, logText) <- case details of -+ Direct -> return (stdout, stderr, "") -+ _ -> do -+ (rOut, wOut) <- createPipe -+ -+ -- Read test executable's output lazily (returns immediately) -+ logText <- hGetContents rOut -+ -- Force the IO manager to drain the test output pipe -+ void $ forkIO $ length logText `seq` return () - -- -- Read test executable's output lazily (returns immediately) -- logText <- hGetContents rOut -- -- Force the IO manager to drain the test output pipe -- void $ forkIO $ length logText `seq` return () -+ -- '--show-details=streaming': print the log output in another thread -+ when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText - -- -- '--show-details=streaming': print the log output in another thread -- when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText -+ return (wOut, wOut, logText) - - -- Run the test executable - let opts = map (testOption pkg_descr lbi suite) -@@ -93,7 +98,7 @@ - - exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') - -- these handles are automatically closed -- Nothing (Just wOut) (Just wOut) -+ Nothing (Just wOut) (Just wErr) - - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log. -@@ -112,12 +117,10 @@ - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let whenPrinting = when $ -- (details > Never) -- && (not (suitePassed $ testLogs suiteLog) || details == Always) -+ ( details == Always || -+ details == Failures && not (suitePassed $ testLogs suiteLog)) - -- verbosity overrides show-details - && verbosity >= normal -- -- if streaming, we already printed the log -- && details /= Streaming - whenPrinting $ putStr $ unlines $ lines logText - - -- Write summary notice to terminal indicating end of test suite diff --git a/ghc-7.10.3b-src.tar.xz b/ghc-7.10.3b-src.tar.xz deleted file mode 100644 index 33162e9..0000000 --- a/ghc-7.10.3b-src.tar.xz +++ /dev/null @@ -1,3 +0,0 @@ -version https://git-lfs.github.com/spec/v1 -oid sha256:06c6c20077dc3cf7ea3f40126b2128ce5ab144e1fa66fd1c05ae1ade3dfaa8e5 -size 11924848 diff --git a/ghc-8.0.1-src.tar.xz b/ghc-8.0.1-src.tar.xz new file mode 100644 index 0000000..ebf1e27 --- /dev/null +++ b/ghc-8.0.1-src.tar.xz @@ -0,0 +1,3 @@ +version https://git-lfs.github.com/spec/v1 +oid sha256:90fb20cd8712e3c0fbeb2eac8dab6894404c21569746655b9b12ca9684c7d1d2 +size 10645912 diff --git a/ghc-no-madv-free.patch b/ghc-no-madv-free.patch new file mode 100644 index 0000000..6d0dd04 --- /dev/null +++ b/ghc-no-madv-free.patch @@ -0,0 +1,18 @@ +Index: ghc-8.0.1/rts/posix/OSMem.c +=================================================================== +--- ghc-8.0.1.orig/rts/posix/OSMem.c ++++ ghc-8.0.1/rts/posix/OSMem.c +@@ -504,13 +504,7 @@ void osDecommitMemory(void *at, W_ size) + sysErrorBelch("unable to make released memory unaccessible"); + #endif + +-#ifdef MADV_FREE +- // Try MADV_FREE first, FreeBSD has both and MADV_DONTNEED +- // just swaps memory out +- r = madvise(at, size, MADV_FREE); +-#else + r = madvise(at, size, MADV_DONTNEED); +-#endif + if(r < 0) + sysErrorBelch("unable to decommit memory"); + } diff --git a/ghc-rpmlintrc b/ghc-rpmlintrc index 24967dc..49ab739 100644 --- a/ghc-rpmlintrc +++ b/ghc-rpmlintrc @@ -2,8 +2,6 @@ addFilter("devel-file-in-non-devel-package") addFilter("static-library-without-debuginfo") # ghc-compiler has devel-dependency addFilter("devel-dependency") -# Haskell needs executable stack -addFilter("executable-stack") # Regrettably, upstream does not provide man pages for all executables addFilter("no-manual-page-for-binary") # Prevent warning about ghc containing no binary (it is a metapackage) diff --git a/ghc.changes b/ghc.changes index f316ae2..460ba06 100644 --- a/ghc.changes +++ b/ghc.changes @@ -1,3 +1,39 @@ +------------------------------------------------------------------- +Fri Oct 14 20:34:46 UTC 2016 - mimi.vx@gmail.com + +- make compatible with new ghc-rpm-macros + +------------------------------------------------------------------- +Wed Sep 28 14:16:09 UTC 2016 - peter.trommler@ohm-hochschule.de + +- update to 8.0.1 +- drop patches fixed upstream: +* drop atomic-cast.patch +* drop cabal-show-detail-direct.patch +* drop 0001-link-command-line-libs-to-temp-so.patch +* drop 0001-implement-native-code-generator-for-ppc64.patch +* drop ghc.git-b29f20.patch +* drop u_terminfo_0402.patch +* drop u_Cabal_update.patch +* drop u_haskeline_update.patch +* drop 0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch +* drop D2214.patch +* drop D2225.patch +- refresh 0001-StgCmmPrim-Add-missing-write-barrier.patch +- refresh 0001-PPC-CodeGen-fix-lwa-instruction-generation.patch +- add ghc-no-madv-free.patch to fix "unable to decommit memory: + Invalid argument" errors GHC reports due to a misdetected + MADV_FREE capability. The configure script sees the symbol define + by glibc, but unfortunately this doesn't mean that the running + kernel actually supports the feature, too. The upstream ticket + https://ghc.haskell.org/trac/ghc/ticket/12495 has more details. + Thanks to @psimons +- GHC produces debug information on x86 and x86_64 +- aarch64 has LLVM backend (requires llvm-3.7) +- native code generator for powerpc64[le] (openSUSE contribution!) +- disable html doc on SLE, we don't have python-sphinx +* Thanks @mimi_vx + ------------------------------------------------------------------- Tue Sep 27 11:53:54 UTC 2016 - peter.trommler@ohm-hochschule.de diff --git a/ghc.git-b29f20.patch b/ghc.git-b29f20.patch deleted file mode 100644 index 938fa23..0000000 --- a/ghc.git-b29f20.patch +++ /dev/null @@ -1,79 +0,0 @@ -From b29f20edb1ca7f1763ceb001e2bb2d5f2f11bec3 Mon Sep 17 00:00:00 2001 -From: Peter Trommler -Date: Fri, 2 Oct 2015 15:48:30 +0200 -Subject: [PATCH] nativeGen PPC: fix > 16 bit offsets in stack handling - -Implement access to spill slots at offsets larger than 16 bits. -Also allocation and deallocation of spill slots was restricted to -16 bit offsets. Now 32 bit offsets are supported on all PowerPC -platforms. - -The implementation of 32 bit offsets requires more than one instruction -but the native code generator wants one instruction. So we implement -pseudo-instructions that are pretty printed into multiple assembly -instructions. - -With pseudo-instructions for spill slot allocation and deallocation -we can also implement handling of the back chain pointer according -to the ELF ABIs. - -Test Plan: validate (especially on powerpc (32 bit)) - -Reviewers: bgamari, austin, erikd - -Reviewed By: erikd - -Subscribers: thomie - -Differential Revision: https://phabricator.haskell.org/D1296 - -GHC Trac Issues: #7830 ---- - compiler/nativeGen/PPC/Instr.hs | 39 ++++++++++++++++++++++++++++----------- - compiler/nativeGen/PPC/Ppr.hs | 33 +++++++++++++++++++++++++++++++++ - compiler/nativeGen/PPC/Regs.hs | 14 ++++++++++++-- - includes/CodeGen.Platform.hs | 18 +++++++++++++----- - 4 files changed, 86 insertions(+), 18 deletions(-) - -Index: ghc-7.10.2.20151105/compiler/nativeGen/PPC/Instr.hs -=================================================================== ---- ghc-7.10.2.20151105.orig/compiler/nativeGen/PPC/Instr.hs -+++ ghc-7.10.2.20151105/compiler/nativeGen/PPC/Instr.hs -@@ -75,17 +75,19 @@ instance Instruction Instr where - - ppc_mkStackAllocInstr :: Platform -> Int -> Instr - ppc_mkStackAllocInstr platform amount -- = case platformArch platform of -- ArchPPC -> UPDATE_SP II32 (ImmInt (-amount)) -- ArchPPC_64 _ -> STU II64 sp (AddrRegImm sp (ImmInt (-amount))) -- arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch -+ = ppc_mkStackAllocInstr' platform (-amount) - - ppc_mkStackDeallocInstr :: Platform -> Int -> Instr - ppc_mkStackDeallocInstr platform amount -- = case platformArch platform of -- ArchPPC -> UPDATE_SP II32 (ImmInt amount) -- ArchPPC_64 _ -> ADD sp sp (RIImm (ImmInt amount)) -- arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch -+ = ppc_mkStackAllocInstr' platform amount -+ -+ppc_mkStackAllocInstr' :: Platform -> Int -> Instr -+ppc_mkStackAllocInstr' platform amount -+ = case platformArch platform of -+ ArchPPC -> UPDATE_SP II32 (ImmInt amount) -+ ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount) -+ _ -> panic $ "ppc_mkStackAllocInstr' " -+ ++ show (platformArch platform) - - -- - -- See note [extra spill slots] in X86/Instr.hs -Index: ghc-7.10.2.20151105/compiler/nativeGen/PPC/Regs.hs -=================================================================== ---- ghc-7.10.2.20151105.orig/compiler/nativeGen/PPC/Regs.hs -+++ ghc-7.10.2.20151105/compiler/nativeGen/PPC/Regs.hs -@@ -335,4 +335,5 @@ tmpReg :: Platform -> Reg - tmpReg platform = - case platformArch platform of - ArchPPC -> regSingle 13 -+ ArchPPC_64 _ -> regSingle 30 - _ -> panic "PPC.Regs.tmpReg: unknowm arch" diff --git a/ghc.spec b/ghc.spec index 2b056f6..af225c9 100644 --- a/ghc.spec +++ b/ghc.spec @@ -16,22 +16,27 @@ # +%if 0%{?suse_version} == 1315 && !0%{?is_opensuse} +%define without_manual 1 +%endif + %global unregisterised_archs aarch64 s390 s390x Name: ghc -Version: 7.10.3 +Version: 8.0.1 Release: 0 -Url: http://haskell.org/ghc/dist/%{version}/%{name}-%{version}-src.tar.bz2 +Url: http://haskell.org/ghc/dist/%{version}/%{name}-%{version}-src.tar.xz Summary: The Glorious Glasgow Haskell Compiler License: BSD-3-Clause Group: Development/Languages/Other ExclusiveArch: aarch64 %{ix86} x86_64 ppc ppc64 ppc64le s390 s390x BuildRequires: binutils-devel BuildRequires: gcc -BuildRequires: ghc-bootstrap >= 7.6 +BuildRequires: ghc-bootstrap >= 7.8 BuildRequires: ghc-rpm-macros-extra BuildRequires: glibc-devel BuildRequires: gmp-devel +BuildRequires: libdw-devel BuildRequires: libelf-devel #Fix for openSUSE:Leap:42.1 %if 0%{?suse_version} == 1315 @@ -39,59 +44,35 @@ BuildRequires: libffi48-devel %else BuildRequires: libffi-devel %endif -#TODO ghc-7.10.2 supports only llvm-3.5, need talk with llvm packagers about +%ifarch aarch64 +BuildRequires: binutils-gold +%endif +#TODO ghc-8.0.1 supports only llvm-3.7, need talk with llvm packagers about # versioned build of llvm -#%%ifnarch ppc aarch64 +# Currently, there is no llvm support for powerpc* in GHC. +# Aarch64 has unregisterised LLVM backend, we need llvm 3.7.x +#%%ifarch aarch64 %{ix86} x86_64 #BuildRequires: llvm #%%endif BuildRequires: ncurses-devel BuildRequires: pkg-config BuildRequires: xz %if %{undefined without_manual} -BuildRequires: docbook-utils -BuildRequires: docbook-xsl-stylesheets -BuildRequires: libxslt +BuildRequires: python-sphinx %endif -%ifarch aarch64 -BuildRequires: binutils-gold -%endif - -# Patch 19 changes build system -BuildRequires: autoconf -BuildRequires: automake PreReq: update-alternatives Requires: ghc-compiler = %{version}-%{release} Requires: ghc-ghc-devel = %{version}-%{release} Requires: ghc-libraries = %{version}-%{release} -Source: http://haskell.org/ghc/dist/%{version}/%{name}-%{version}b-src.tar.xz +Source: http://haskell.org/ghc/dist/%{version}/%{name}-%{version}-src.tar.xz Source1: ghc-rpmlintrc -# PATCH-FIX-UPSTREAM fix signature of atomic builtins (#10926) -Patch1: atomic-cast.patch -# PATCH-FIX-UPSTREAM cabal-show-detail-direct.patch peter.trommler@ohm-hochschule.de -- Fix testsuites with large output. Debian patch. Thanks Joachim for suggesting it in Haskell #10870! -Patch3: cabal-show-detail-direct.patch -# PATCH_FIX-UPSTREAM 0001-link-command-line-libs-to-temp-so.patch -- peter.trommler@ohm-hochschule.de -- Fix panic in GHCi. See Haskell trac #10458. -Patch4: 0001-link-command-line-libs-to-temp-so.patch -# PATCH-FEATURE-UPSTREAM 0001-implement-native-code-generator-for-ppc64.patch peter.trommler@ohm-hochschule.de -- Implement native code generator for ppc64. Haskell Trac #9863. -Patch19: 0001-implement-native-code-generator-for-ppc64.patch -# PATCH-FIX-UPSTREAM ghc.git-b29f20.patch peter.trommler@ohm-hochschule.de -- nativeGen PPC: fix > 16 bit offsets in stack handling. This is a backport of my patch for Haskell trac #7830. We do not use erikd's patch because we have 64 bit native code generation for ppc64[le]. See patch 19. -Patch20: ghc.git-b29f20.patch -# PATCH-FIX-UPSTREAM u_terminfo_0402.patch mimi.vx@gmail.com -- update terminfo to 0.4.0.2 -Patch21: u_terminfo_0402.patch -# PATCH-FIX-UPSTREAM u_Cabal_update.patch mimi.vx@gmail.com -- update Cabal to 1.22.6.0 -Patch22: u_Cabal_update.patch -# PATCH-FIX-UPSTREAM u_haskeline_update.patch mimi.vx@gmail.com -- update haskeline to 0.7.2.3 -Patch23: u_haskeline_update.patch -# PATCH-FIX-UPSTREAM 0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch peter.trommler@ohm-hochschule.de -- Fix ghc-pureMD5 and other Haskell packages on big-endian architectures. -Patch24: 0001-Fix-misspelled-WORDS_BIGENDIAN-macro.patch -# PATCH-FIX-UPSTREAM D2214.patch peter.trommler@ohm-hochschule.de -- Fix PowerPC code generator. See Haskell Trac #12054 and https://phabricator.haskell.org/D2214 for details. -Patch25: D2214.patch -# PATCH-FIX-UPSTREAM D2225.patch peter.trommler@ohm-hochschule.de -- Fix SMP imlementation in Haskell runtime on PPC[64[le]]. Backport of upstreamed patch. See Haskell trac #12070 and https://phabricator.haskell.org/D2225 for details. -Patch26: D2225.patch # PATCH-FIX-UPSTREAM D2495.patch peter.trommler@ohm-hochschule.de -- Add missing memory barrier on mutable variables. See https://ghc.haskell.org/trac/ghc/ticket/12469 for details. Backport of upstream fix for ghc 8.0.2. Patch27: D2495.patch # PATCH-FIX_UPSTREAM 0001-StgCmmPrim-Add-missing-write-barrier.patch peter.trommler@ohm-hochschule.de -- Add missing write barrier on mutable arrays. Patch28: 0001-StgCmmPrim-Add-missing-write-barrier.patch +# PATCH-FIX_UPSTREAM ghc-no-madv-free.patch psimons@suse.com -- Fix "unable to decommit memory: Invalid argument" errors. See https://ghc.haskell.org/trac/ghc/ticket/12495 for details. +Patch29: ghc-no-madv-free.patch # PATCH-FIX-UPSTREAM 0001-PPC-CodeGen-fix-lwa-instruction-generation.patch peter.trommler@ohm-hochschule.de -- Fix PPC codegen: Fixes ghc-zeromq4-haskell build on 64-bit PowerPCs Patch30: 0001-PPC-CodeGen-fix-lwa-instruction-generation.patch @@ -119,10 +100,6 @@ Summary: GHC compiler and utilities Group: Development/Languages/Other Requires: gcc Requires: ghc-base-devel -# This Requires fixes an issue in ghc's runtime system (rts) when -# locale files are missing. RTS loops and a memory leak eventually -# exhausts all memory and the program crashes. See Haskell trac #7695. -Requires: glibc-locale Requires(post): update-alternatives Requires(postun): update-alternatives %ifarch aarch64 @@ -140,29 +117,30 @@ To install all of GHC install package ghc. %global ghc_pkg_c_deps ghc-compiler = %{ghc_version_override}-%{release} %if %{defined ghclibdir} -%ghc_lib_subpackage Cabal 1.22.8.0 -%ghc_lib_subpackage array 0.5.1.0 -%ghc_lib_subpackage -c gmp-devel,libffi-devel base 4.8.2.0 -%ghc_lib_subpackage binary 0.7.5.0 -%ghc_lib_subpackage bytestring 0.10.6.0 -%ghc_lib_subpackage containers 0.5.6.2 -%ghc_lib_subpackage deepseq 1.4.1.1 -%ghc_lib_subpackage directory 1.2.2.0 -%ghc_lib_subpackage filepath 1.4.0.0 -%define ghc_pkg_obsoletes ghc-bin-package-db-devel < 0.0.0.0-%{release} -%ghc_lib_subpackage -x ghc %{ghc_version_override} -%undefine ghc_pkg_obsoletes -%ghc_lib_subpackage haskeline 0.7.2.3 -%ghc_lib_subpackage hoopl 3.10.0.2 -%ghc_lib_subpackage hpc 0.6.0.2 -%ghc_lib_subpackage pretty 1.1.2.0 -%ghc_lib_subpackage process 1.2.3.0 -%ghc_lib_subpackage template-haskell 2.10.0.0 -%ghc_lib_subpackage -c ncurses-devel terminfo 0.4.0.2 -%ghc_lib_subpackage time 1.5.0.1 -%ghc_lib_subpackage transformers 0.4.2.0 -%ghc_lib_subpackage unix 2.7.1.0 -%ghc_lib_subpackage xhtml 3000.2.1 +%ghc_lib_subpackage Cabal-1.24.0.0 +%ghc_lib_subpackage array-0.5.1.1 +%ghc_lib_subpackage -c gmp-devel,libffi-devel,libdw-devel,libelf-devel base-4.9.0.0 +%ghc_lib_subpackage binary-0.8.3.0 +%ghc_lib_subpackage bytestring-0.10.8.1 +%ghc_lib_subpackage containers-0.5.7.1 +%ghc_lib_subpackage deepseq-1.4.2.0 +%ghc_lib_subpackage directory-1.2.6.2 +%ghc_lib_subpackage filepath-1.4.1.0 +%ghc_lib_subpackage -x ghc-%{ghc_version_override} +%ghc_lib_subpackage ghc-boot-%{ghc_version_override} +%ghc_lib_subpackage ghc-boot-th-%{ghc_version_override} +%ghc_lib_subpackage -x ghci-%{ghc_version_override} +%ghc_lib_subpackage haskeline-0.7.2.3 +%ghc_lib_subpackage hoopl-3.10.2.1 +%ghc_lib_subpackage hpc-0.6.0.3 +%ghc_lib_subpackage pretty-1.1.3.3 +%ghc_lib_subpackage process-1.4.2.0 +%ghc_lib_subpackage template-haskell-2.11.0.0 +%ghc_lib_subpackage -c ncurses-devel terminfo-0.4.0.2 +%ghc_lib_subpackage time-1.6.0.1 +%ghc_lib_subpackage transformers-0.5.2.0 +%ghc_lib_subpackage unix-2.7.2.0 +%ghc_lib_subpackage xhtml-3000.2.1 %endif %global version %{ghc_version_override} @@ -183,25 +161,12 @@ except the ghc library, which is installed by the toplevel ghc metapackage. %prep %setup -q -%patch1 -p1 -%patch3 -p1 -%patch4 -p1 -%patch19 -p1 -%patch20 -p1 -%patch21 -p2 -%patch22 -p2 -%patch23 -p2 -%patch24 -p1 -%patch25 -p1 -%patch26 -p1 %patch27 -p1 %patch28 -p1 +%patch29 -p1 %patch30 -p1 %build -# Patch 19 modifies build system -./boot - # Check if bootstrap is required, i.e. version is different from ghc's version # Note: Cannot use ghc_version macro here as we defined version override earlier %if "%version" != "%(ghc --numeric-version)" @@ -225,7 +190,9 @@ SRC_HC_OPTS += -optc-fno-builtin SRC_CC_OPTS += -fno-builtin %endif HADDOCK_DOCS = NO -BUILD_DOCBOOK_HTML = NO +BUILD_SPHINX_HTML = NO +BUILD_SPHINX_PS = NO +BUILD_SPHINX_PDF = NO HSCOLOUR_SRCS = NO EOF ./configure --prefix=%{_builddir}/ghc-boot --with-system-libffi @@ -261,14 +228,16 @@ GhcStage1HcOpts = -O GhcStage2HcOpts = -O GhcHcOpts = -Rghc-timing GhcLibHcOpts = -O -SRC_HC_OPTS += -optc-fno-builtin -SRC_CC_OPTS += -fno-builtin +SRC_HC_OPTS += -optc-fno-builtin -optc-Wno-return-type +SRC_CC_OPTS += -fno-builtin -Wno-return-type %endif %if %{defined without_haddock} HADDOCK_DOCS = NO %endif +BUILD_SPHINX_PS = NO %if %{defined without_manual} -BUILD_DOCBOOK_HTML = NO +BUILD_SPHINX_HTML = NO +BUILD_SPHINX_PDF = NO %endif %if %{defined without_hscolour} HSCOLOUR_SRCS = NO @@ -291,7 +260,7 @@ make -j 2 %endif %install -%ghc_suse_disable_debug_packages +#%%ghc_suse_disable_debug_packages %makeinstall for i in %{ghc_packages_list}; do @@ -304,10 +273,10 @@ done # ghc-base should own ghclibdir echo "%dir %{ghclibdir}" >> ghc-base.files -%ghc_gen_filelists bin-package-db 0.0.0.0 %ghc_gen_filelists ghc %{ghc_version_override} -%ghc_gen_filelists ghc-prim 0.4.0.0 -%ghc_gen_filelists integer-gmp 1.0.0.0 +%ghc_gen_filelists ghci %{ghc_version_override} +%ghc_gen_filelists ghc-prim 0.5.0.0 +%ghc_gen_filelists integer-gmp 1.0.0.1 %define merge_filelist()\ cat ghc-%1.files >> ghc-%2.files\ @@ -317,7 +286,6 @@ echo "%doc libraries/LICENSE.%1" >> ghc-%2.files %merge_filelist integer-gmp base %merge_filelist ghc-prim base -%merge_filelist bin-package-db ghc %if %{undefined ghc_without_shared} echo %%dir %{ghclibdir}/rts >> ghc-base.files @@ -325,7 +293,7 @@ ls %{buildroot}%{ghclibdir}/rts/libHS*.so >> ghc-base.files sed -i -e "s|^%{buildroot}||g" ghc-base.files %endif echo %%dir %{ghclibdir}/rts >> ghc-base-devel.files -ls -d %{buildroot}%{ghclibdir}/rts/libHS*.a %{buildroot}%{ghclibdir}/package.conf.d/builtin_*.conf %{buildroot}%{ghclibdir}/include >> ghc-base-devel.files +ls -d %{buildroot}%{ghclibdir}/rts/libHS*.a %{buildroot}%{ghclibdir}/package.conf.d/rts.conf %{buildroot}%{ghclibdir}/include >> ghc-base-devel.files sed -i -e "s|^%{buildroot}||g" ghc-base-devel.files # these are handled as alternatives @@ -342,6 +310,8 @@ done %ghc_strip_dynlinked +find %{buildroot}%{ghclibdocdir} -name LICENSE -exec rm '{}' ';' + %check # Actually, I took this from Jens Petersen's Fedora package # stolen from ghc6/debian/rules: @@ -414,10 +384,13 @@ fi %dir %{ghclibdir}/bin %{ghclibdir}/bin/ghc %{ghclibdir}/bin/ghc-pkg +%{ghclibdir}/bin/ghc-iserv +%{ghclibdir}/bin/ghc-iserv-dyn +%{ghclibdir}/bin/ghc-iserv-prof %{ghclibdir}/bin/hpc %{ghclibdir}/bin/hsc2hs %ifnarch %{unregisterised_archs} -%{ghclibdir}/ghc-split +%{ghclibdir}/bin/ghc-split %endif %{ghclibdir}/ghc-usage.txt %{ghclibdir}/ghci-usage.txt @@ -426,8 +399,8 @@ fi %{ghclibdir}/platformConstants %{ghclibdir}/bin/runghc %{ghclibdir}/template-hsc.h -%{ghclibdir}/unlit -%dir %{_datadir}/doc/ghc +%{ghclibdir}/bin/unlit +%dir %{_datadir}/doc/ghc-%{version} %dir %{ghcdocbasedir} %dir %{ghcdocbasedir}/libraries %if %{undefined without_manual} diff --git a/u_Cabal_update.patch b/u_Cabal_update.patch deleted file mode 100644 index 9ca16d8..0000000 --- a/u_Cabal_update.patch +++ /dev/null @@ -1,246 +0,0 @@ -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Cabal.cabal b/ghc-7.10.3/libraries/Cabal/Cabal/Cabal.cabal -index b498ca0..e8bfb00 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Cabal.cabal -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/Cabal.cabal -@@ -1,5 +1,5 @@ - name: Cabal --version: 1.22.5.0 -+version: 1.22.8.0 - copyright: 2003-2006, Isaac Jones - 2005-2011, Duncan Coutts - license: BSD3 -@@ -19,7 +19,7 @@ description: - organizing, and cataloging Haskell libraries and tools. - category: Distribution - cabal-version: >=1.10 --build-type: Custom -+build-type: Simple - -- Even though we do use the default Setup.lhs it's vital to bootstrapping - -- that we build Setup.lhs using our own local Cabal source code. - -@@ -145,7 +145,7 @@ library - if flag(bundled-binary-generic) - build-depends: binary >= 0.5 && < 0.7 - else -- build-depends: binary >= 0.7 && < 0.8 -+ build-depends: binary >= 0.7 && < 0.9 - - -- Needed for GHC.Generics before GHC 7.6 - if impl(ghc < 7.6) -@@ -265,7 +265,7 @@ test-suite unit-tests - test-framework-hunit, - test-framework-quickcheck2, - HUnit, -- QuickCheck < 2.8, -+ QuickCheck < 2.9, - Cabal - ghc-options: -Wall - default-language: Haskell98 -@@ -312,7 +312,7 @@ test-suite package-tests - test-framework-quickcheck2 >= 0.2.12, - test-framework-hunit, - HUnit, -- QuickCheck >= 2.1.0.1 && < 2.8, -+ QuickCheck >= 2.1.0.1 && < 2.9, - Cabal, - process, - directory, -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/GHC.hs b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/GHC.hs -index 444c851..fa6d8a8 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/GHC.hs -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/GHC.hs -@@ -542,19 +542,22 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir -- needsRecomp <- checkNeedsRecompilation filename vanillaCcOpts -- when needsRecomp $ do -- runGhcProg vanillaCcOpts -- unless forRepl $ -- whenSharedLib forceSharedLib (runGhcProg sharedCcOpts) -- unless forRepl $ whenProfLib (runGhcProg profCcOpts) -+ let runGhcProgIfNeeded ccOpts = do -+ needsRecomp <- checkNeedsRecompilation filename ccOpts -+ when needsRecomp $ runGhcProg ccOpts -+ runGhcProgIfNeeded vanillaCcOpts -+ unless forRepl $ -+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) -+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. -- unless (null (libModules lib)) $ -- ifReplLib (runGhcProg replOpts) -+ -+ ifReplLib $ do -+ when (null (libModules lib)) $ warn verbosity "No exposed modules" -+ ifReplLib (runGhcProg replOpts) - - -- link: - unless forRepl $ do -@@ -766,7 +769,9 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi - ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, - ghcOptInputFiles = toNubListR -- [exeDir x | x <- cObjs], -+ [exeDir x | x <- cObjs] -+ } -+ dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { -@@ -812,9 +817,9 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi - | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) - - linkOpts = commonOpts `mappend` -- linkerOpts `mappend` mempty { -- ghcOptLinkNoHsMain = toFlag (not isHaskellMain) -- } -+ linkerOpts `mappend` -+ mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } `mappend` -+ (if withDynExe lbi then dynLinkerOpts else mempty) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/Haddock.hs b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/Haddock.hs -index 095d6b8..2d09292 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/Haddock.hs -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/Haddock.hs -@@ -84,14 +84,16 @@ import Language.Haskell.Extension - - - import Control.Monad ( when, forM_ ) -+import Data.Char ( isSpace ) - import Data.Either ( rights ) - import Data.Monoid -+import Data.Foldable ( foldl' ) - import Data.Maybe ( fromMaybe, listToMaybe ) - - import System.Directory (doesFileExist) - import System.FilePath ( (), (<.>) - , normalise, splitPath, joinPath, isAbsolute ) --import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) -+import System.IO (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8) - import Distribution.Version - - -- ------------------------------------------------------------------------------ -@@ -467,7 +469,7 @@ renderArgs :: Verbosity - -> IO a - renderArgs verbosity tmpFileOpts version comp args k = do - let haddockSupportsUTF8 = version >= Version [2,14,4] [] -- haddockSupportsResponseFiles = version > Version [2,16,1] [] -+ haddockSupportsResponseFiles = version > Version [2,16,2] [] - createDirectoryIfMissingVerbose verbosity True outputDir - withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ - \prologueFileName h -> do -@@ -482,7 +484,7 @@ renderArgs verbosity tmpFileOpts version comp args k = do - withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $ - \responseFileName hf -> do - when haddockSupportsUTF8 (hSetEncoding hf utf8) -- mapM_ (hPutStrLn hf) renderedArgs -+ hPutStr hf $ unlines $ map escapeArg renderedArgs - hClose hf - let respFile = "@" ++ responseFileName - k ([respFile], result) -@@ -500,6 +502,19 @@ renderArgs verbosity tmpFileOpts version comp args k = do - pkgstr = display $ packageName pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args -+ -- Support a gcc-like response file syntax. Each separate -+ -- argument and its possible parameter(s), will be separated in the -+ -- response file by an actual newline; all other whitespace, -+ -- single quotes, double quotes, and the character used for escaping -+ -- (backslash) are escaped. The called program will need to do a similar -+ -- inverse operation to de-escape and re-constitute the argument list. -+ escape cs c -+ | isSpace c -+ || '\\' == c -+ || '\'' == c -+ || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result -+ | otherwise = c:cs -+ escapeArg = reverse . foldl' escape [] - - renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] - renderPureArgs version comp args = concat -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs -index b87b567..abda3c7 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Simple/Setup.hs -@@ -2099,7 +2099,6 @@ optionNumJobs get set = - _ -> case reads s of - [(n, "")] - | n < 1 -> Left "The number of jobs should be 1 or more." -- | n > 64 -> Left "You probably don't want that many jobs." - | otherwise -> Right (Just n) - _ -> Left "The jobs value should be a number or '$ncpus'" - -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Version.hs b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Version.hs -index 1123749..e5c2e28 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/Distribution/Version.hs -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/Distribution/Version.hs -@@ -3,7 +3,25 @@ - #if __GLASGOW_HASKELL__ < 707 - {-# LANGUAGE StandaloneDeriving #-} - #endif -+ -+-- Hack approach to support bootstrapping -+-- Assume binary <0.8 when MIN_VERSION_binary macro is not available. -+-- Starting with GHC>=8.0, compiler will hopefully provide this macros too. -+-- https://ghc.haskell.org/trac/ghc/ticket/10970 -+-- -+-- Otherwise, one can specify -DMIN_VERSION_binary_0_8_0=1, when bootstrapping -+-- with binary >=0.8.0.0 -+#ifdef MIN_VERSION_binary -+#define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0) -+#else -+#ifndef MIN_VERSION_binary_0_8_0 -+#define MIN_VERSION_binary_0_8_0 0 -+#endif -+#endif -+ -+#if !MIN_VERSION_binary_0_8_0 - {-# OPTIONS_GHC -fno-warn-orphans #-} -+#endif - - ----------------------------------------------------------------------------- - -- | -@@ -109,6 +127,7 @@ instance Binary VersionRange - deriving instance Data Version - #endif - -+#if !(MIN_VERSION_binary_0_8_0) - -- Deriving this instance from Generic gives trouble on GHC 7.2 because the - -- Generic instance has to be standalone-derived. So, we hand-roll our own. - -- We can't use a generic Binary instance on later versions because we must -@@ -119,6 +138,7 @@ instance Binary Version where - tags <- get - return $ Version br tags - put (Version br tags) = put br >> put tags -+#endif - - {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} - {-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -diff --git a/ghc-7.10.3.orig/libraries/Cabal/Cabal/changelog b/ghc-7.10.3/libraries/Cabal/Cabal/changelog -index f5fb8ff..45c15f9 100644 ---- a/ghc-7.10.3.orig/libraries/Cabal/Cabal/changelog -+++ b/ghc-7.10.3/libraries/Cabal/Cabal/changelog -@@ -1,3 +1,17 @@ -+1.22.8.0 Ryan Thomas March 2016 -+ * Distribution.Simple.Setup: remove job cap. Fixes #3191. -+ * Check all object file suffixes for recompilation. Fixes #3128. -+ * Move source files under 'src/'. Fixes #3003. -+ -+1.22.7.0 Ryan Thomas January 2016 -+ * Backport #3012 to the 1.22 branch -+ * Cabal.cabal: change build-type to Simple -+ * Add foldl' import -+ * The Cabal part for fully gcc-like response files -+ -+1.22.6.0 -+ * Relax upper bound to allow upcoming binary-0.8 -+ - 1.22.5.0 - * Don't recompile C sources unless needed (#2601). (Luke Iannini) - * Support Haddock response files. diff --git a/u_haskeline_update.patch b/u_haskeline_update.patch deleted file mode 100644 index 434dd52..0000000 --- a/u_haskeline_update.patch +++ /dev/null @@ -1,1277 +0,0 @@ -diff --git a/ghc-7.10.3.orig/libraries/haskeline/Changelog b/ghc-7.10.3/libraries/haskeline/Changelog -index 5cb7cc5..7b1f5e2 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/Changelog -+++ b/ghc-7.10.3/libraries/haskeline/Changelog -@@ -1,3 +1,15 @@ -+Changed in version 0.7.2.3: -+ * Fix hsc2hs-related warning on ghc-8 -+ * Fix the behavior of ctrl-W in the emacs bindings -+ * Point to github instead of trac -+ -+Changed in version 0.7.2.2: -+ * Fix Linux to Windows cross-compile -+ * Canonicalize AMP instances to make the code more future proof -+ * Generalize constraints for InputT instances -+ * Bump upper bounds on base and transformers -+ * Make Haskeline `-Wtabs` clean -+ - Changed in version 0.7.2.1: - * Fix build on Windows. - -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc -index 61c9ab2..d9c0934 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc -@@ -1,546 +1,548 @@ --module System.Console.Haskeline.Backend.Win32( -- win32Term, -- win32TermStdin, -- fileRunTerm -- )where -- -- --import System.IO --import Foreign --import Foreign.C --import System.Win32 hiding (multiByteToWideChar) --import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) --import Data.List(intercalate) --import Control.Concurrent hiding (throwTo) --import Data.Char(isPrint) --import Data.Maybe(mapMaybe) --import Control.Applicative --import Control.Monad -- --import System.Console.Haskeline.Key --import System.Console.Haskeline.Monads hiding (Handler) --import System.Console.Haskeline.LineState --import System.Console.Haskeline.Term --import System.Console.Haskeline.Backend.WCWidth -- --import Data.ByteString.Internal (createAndTrim) --import qualified Data.ByteString as B -- --##if defined(i386_HOST_ARCH) --## define WINDOWS_CCONV stdcall --##elif defined(x86_64_HOST_ARCH) --## define WINDOWS_CCONV ccall --##else --## error Unknown mingw32 arch --##endif -- --#include "win_console.h" -- --foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput -- :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool -- --foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject -- :: HANDLE -> DWORD -> IO DWORD -- --foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents" -- c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool -- --getNumberOfEvents :: HANDLE -> IO Int --getNumberOfEvents h = alloca $ \numEventsPtr -> do -- failIfFalse_ "GetNumberOfConsoleInputEvents" -- $ c_GetNumberOfConsoleInputEvents h numEventsPtr -- fmap fromEnum $ peek numEventsPtr -- --getEvent :: HANDLE -> Chan Event -> IO Event --getEvent h = keyEventLoop (eventReader h) -- --eventReader :: HANDLE -> IO [Event] --eventReader h = do -- let waitTime = 500 -- milliseconds -- ret <- c_WaitForSingleObject h waitTime -- yield -- otherwise, the above foreign call causes the loop to never -- -- respond to the killThread -- if ret /= (#const WAIT_OBJECT_0) -- then eventReader h -- else do -- es <- readEvents h -- return $ mapMaybe processEvent es -- --consoleHandles :: MaybeT IO Handles --consoleHandles = do -- h_in <- open "CONIN$" -- h_out <- open "CONOUT$" -- return Handles { hIn = h_in, hOut = h_out } -- where -- open file = handle (\(_::IOException) -> mzero) $ liftIO -- $ createFile file (gENERIC_READ .|. gENERIC_WRITE) -- (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing -- oPEN_EXISTING 0 Nothing -- -- --processEvent :: InputEvent -> Maybe Event --processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, -- controlKeyState = cstate} -- = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar -- where -- simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c) -- testMod ck = (cstate .&. ck) /= 0 -- modifier' = if hasMeta modifier && hasControl modifier -- then noModifier {hasShift = hasShift modifier} -- else modifier -- modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) -- .|. (#const LEFT_ALT_PRESSED)) -- ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) -- .|. (#const LEFT_CTRL_PRESSED)) -- && not (c > '\NUL' && c <= '\031') -- ,hasShift = testMod (#const SHIFT_PRESSED) -- && not (isPrint c) -- } -- --processEvent WindowEvent = Just WindowResize --processEvent _ = Nothing -- --keyFromCode :: WORD -> Maybe BaseKey --keyFromCode (#const VK_BACK) = Just Backspace --keyFromCode (#const VK_LEFT) = Just LeftKey --keyFromCode (#const VK_RIGHT) = Just RightKey --keyFromCode (#const VK_UP) = Just UpKey --keyFromCode (#const VK_DOWN) = Just DownKey --keyFromCode (#const VK_DELETE) = Just Delete --keyFromCode (#const VK_HOME) = Just Home --keyFromCode (#const VK_END) = Just End --keyFromCode (#const VK_PRIOR) = Just PageUp --keyFromCode (#const VK_NEXT) = Just PageDown ---- The Windows console will return '\r' when return is pressed. --keyFromCode (#const VK_RETURN) = Just (KeyChar '\n') ---- TODO: KillLine? ---- TODO: function keys. --keyFromCode _ = Nothing -- --data InputEvent = KeyEvent {keyDown :: BOOL, -- repeatCount :: WORD, -- virtualKeyCode :: WORD, -- virtualScanCode :: WORD, -- unicodeChar :: Char, -- controlKeyState :: DWORD} -- -- TODO: WINDOW_BUFFER_SIZE_RECORD -- -- I cant figure out how the user generates them. -- | WindowEvent -- | OtherEvent -- deriving Show -- --peekEvent :: Ptr () -> IO InputEvent --peekEvent pRecord = do -- eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord -- let eventPtr = (#ptr INPUT_RECORD, Event) pRecord -- case eventType of -- (#const KEY_EVENT) -> getKeyEvent eventPtr -- (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent -- _ -> return OtherEvent -- --readEvents :: HANDLE -> IO [InputEvent] --readEvents h = do -- n <- getNumberOfEvents h -- alloca $ \numEventsPtr -> -- allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do -- failIfFalse_ "ReadConsoleInput" -- $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr -- numRead <- fmap fromEnum $ peek numEventsPtr -- forM [0..toEnum numRead-1] $ \i -> peekEvent -- $ pRecord `plusPtr` (i * #size INPUT_RECORD) -- --getKeyEvent :: Ptr () -> IO InputEvent --getKeyEvent p = do -- kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p -- repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p -- keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p -- scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p -- char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p -- state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p -- return KeyEvent {keyDown = kDown', -- repeatCount = repeat', -- virtualKeyCode = keyCode, -- virtualScanCode = scanCode, -- unicodeChar = toEnum (fromEnum char), -- controlKeyState = state} -- --data Coord = Coord {coordX, coordY :: Int} -- deriving Show -- --#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) --instance Storable Coord where -- sizeOf _ = (#size COORD) -- alignment _ = (#alignment COORD) -- peek p = do -- x :: CShort <- (#peek COORD, X) p -- y :: CShort <- (#peek COORD, Y) p -- return Coord {coordX = fromEnum x, coordY = fromEnum y} -- poke p c = do -- (#poke COORD, X) p (toEnum (coordX c) :: CShort) -- (#poke COORD, Y) p (toEnum (coordY c) :: CShort) -- -- --foreign import ccall "haskeline_SetPosition" -- c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool -- --setPosition :: HANDLE -> Coord -> IO () --setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" -- . c_SetPosition h -- --foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo" -- c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool -- --getPosition :: HANDLE -> IO Coord --getPosition = withScreenBufferInfo $ -- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) -- --withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a --withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO) -- $ \infoPtr -> do -- failIfFalse_ "GetConsoleScreenBufferInfo" -- $ c_GetScreenBufferInfo h infoPtr -- f infoPtr -- --getBufferSize :: HANDLE -> IO Layout --getBufferSize = withScreenBufferInfo $ \p -> do -- c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p -- return Layout {width = coordX c, height = coordY c} -- --foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW -- :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool -- --writeConsole :: HANDLE -> String -> IO () ---- For some reason, Wine returns False when WriteConsoleW is called on an empty ---- string. Easiest fix: just don't call that function. --writeConsole _ "" = return () --writeConsole h str = writeConsole' >> writeConsole h ys -- where -- (xs,ys) = splitAt limit str -- -- WriteConsoleW has a buffer limit which is documented as 32768 word8's, -- -- but bug reports from online suggest that the limit may be lower (~25000). -- -- To be safe, we pick a round number we know to be less than the limit. -- limit = 20000 -- known to be less than WriteConsoleW's buffer limit -- writeConsole' -- = withArray (map (toEnum . fromEnum) xs) -- $ \t_arr -> alloca $ \numWritten -> do -- failIfFalse_ "WriteConsoleW" -- $ c_WriteConsoleW h t_arr (toEnum $ length xs) -- numWritten nullPtr -- --foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool -- --messageBeep :: IO () --messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. -- -- ------------ ---- Console mode --foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode -- :: HANDLE -> Ptr DWORD -> IO Bool -- --foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode -- :: HANDLE -> DWORD -> IO Bool -- --withWindowMode :: MonadException m => Handles -> m a -> m a --withWindowMode hs f = do -- let h = hIn hs -- bracket (getConsoleMode h) (setConsoleMode h) -- $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f -- where -- getConsoleMode h = liftIO $ alloca $ \p -> do -- failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p -- peek p -- setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m -- ------------------------------ ---- Drawing -- --data Handles = Handles { hIn, hOut :: HANDLE } -- --closeHandles :: Handles -> IO () --closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) -- --newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} -- deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles) -- --type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a -- --instance MonadTrans Draw where -- lift = Draw . lift -- --getPos :: MonadIO m => Draw m Coord --getPos = asks hOut >>= liftIO . getPosition -- --setPos :: Coord -> DrawM () --setPos c = do -- h <- asks hOut -- -- SetPosition will fail if you give it something out of bounds of -- -- the window buffer (i.e., the input line doesn't fit in the window). -- -- So we do a simple guard against that uncommon case. -- -- However, we don't throw away the x coord since it produces sensible -- -- results for some cases. -- maxY <- liftM (subtract 1) $ asks height -- liftIO $ setPosition h c { coordY = max 0 $ min maxY $ coordY c } -- --printText :: MonadIO m => String -> Draw m () --printText txt = do -- h <- asks hOut -- liftIO (writeConsole h txt) -- --printAfter :: [Grapheme] -> DrawM () --printAfter gs = do -- -- NOTE: you may be tempted to write -- -- do {p <- getPos; printText (...); setPos p} -- -- Unfortunately, that would be WRONG, because if printText wraps -- -- a line at the bottom of the window, causing the window to scroll, -- -- then the old value of p will be incorrect. -- printText (graphemesToString gs) -- movePosLeft gs -- --drawLineDiffWin :: LineChars -> LineChars -> DrawM () --drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of -- ([],[]) | ys1 == ys2 -> return () -- (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1' -- ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2' -- (xs1',xs2') -> do -- movePosLeft xs1' -- let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2) -- let deadText = stringToGraphemes $ replicate m ' ' -- printText (graphemesToString xs2') -- printAfter (ys2 ++ deadText) -- --movePosRight, movePosLeft :: [Grapheme] -> DrawM () --movePosRight str = do -- p <- getPos -- w <- asks width -- setPos $ moveCoord w p str -- where -- moveCoord _ p [] = p -- moveCoord w p cs = case splitAtWidth (w - coordX p) cs of -- (_,[],len) | len < w - coordX p -- stayed on same line -- -> Coord { coordY = coordY p, -- coordX = coordX p + len -- } -- (_,cs',_) -- moved to next line -- -> moveCoord w Coord { -- coordY = coordY p + 1, -- coordX = 0 -- } cs' -- --movePosLeft str = do -- p <- getPos -- w <- asks width -- setPos $ moveCoord w p str -- where -- moveCoord _ p [] = p -- moveCoord w p cs = case splitAtWidth (coordX p) cs of -- (_,[],len) -- stayed on same line -- -> Coord { coordY = coordY p, -- coordX = coordX p - len -- } -- (_,_:cs',_) -- moved to previous line -- -> moveCoord w Coord { -- coordY = coordY p - 1, -- coordX = w-1 -- } cs' -- --crlf :: String --crlf = "\r\n" -- --instance (MonadException m, MonadReader Layout m) => Term (Draw m) where -- drawLineDiff (xs1,ys1) (xs2,ys2) = let -- fixEsc = filter ((/= '\ESC') . baseChar) -- in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2) -- -- TODO now that we capture resize events. -- -- first, looks like the cursor stays on the same line but jumps -- -- to the beginning if cut off. -- reposition _ _ = return () -- -- printLines [] = return () -- printLines ls = printText $ intercalate crlf ls ++ crlf -- -- clearLayout = clearScreen -- -- moveToNextLine s = do -- movePosRight (snd s) -- printText "\r\n" -- make the console take care of creating a new line -- -- ringBell True = liftIO messageBeep -- ringBell False = return () -- TODO -- --win32TermStdin :: MaybeT IO RunTerm --win32TermStdin = do -- liftIO (hIsTerminalDevice stdin) >>= guard -- win32Term -- --win32Term :: MaybeT IO RunTerm --win32Term = do -- hs <- consoleHandles -- ch <- liftIO newChan -- fileRT <- liftIO $ fileRunTerm stdin -- return fileRT { -- termOps = Left TermOps { -- getLayout = getBufferSize (hOut hs) -- , withGetEvent = withWindowMode hs -- . win32WithEvent hs ch -- , saveUnusedKeys = saveKeys ch -- , evalTerm = EvalTerm (runReaderT' hs . runDraw) -- (Draw . lift) -- }, -- closeTerm = closeHandles hs -- } -- --win32WithEvent :: MonadException m => Handles -> Chan Event -- -> (m Event -> m a) -> m a --win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan -- ---- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. --fileRunTerm :: Handle -> IO RunTerm --fileRunTerm h_in = do -- putter <- putOut -- cp <- getCodePage -- return RunTerm { -- closeTerm = return (), -- putStrOut = putter, -- wrapInterrupt = withCtrlCHandler, -- termOps = Right FileOps -- { inputHandle = h_in -- , wrapFileInput = hWithBinaryMode h_in -- , getLocaleChar = getMultiByteChar cp h_in -- , maybeReadNewline = hMaybeReadNewline h_in -- , getLocaleLine = hGetLocaleLine h_in -- >>= liftIO . codePageToUnicode cp -- } -- -- } -- ---- On Windows, Unicode written to the console must be written with the WriteConsole API call. ---- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. --putOut :: IO (String -> IO ()) --putOut = do -- outIsTerm <- hIsTerminalDevice stdout -- if outIsTerm -- then do -- h <- getStdHandle sTD_OUTPUT_HANDLE -- return (writeConsole h) -- else do -- cp <- getCodePage -- return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout -- -- --type Handler = DWORD -> IO BOOL -- --foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) -- --foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler -- :: FunPtr Handler -> BOOL -> IO BOOL -- ---- sets the tv to True when ctrl-c is pressed. --withCtrlCHandler :: MonadException m => m a -> m a --withCtrlCHandler f = bracket (liftIO $ do -- tid <- myThreadId -- fp <- wrapHandler (handler tid) -- -- don't fail if we can't set the ctrl-c handler -- -- for example, we might not be attached to a console? -- _ <- c_SetConsoleCtrlHandler fp True -- return fp) -- (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) -- (const f) -- where -- handler tid (#const CTRL_C_EVENT) = do -- throwTo tid Interrupt -- return True -- handler _ _ = return False -- -- -- -------------------------- ---- Multi-byte conversion -- --foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte -- :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt -- -> LPCSTR -> LPBOOL -> IO CInt -- --unicodeToCodePage :: CodePage -> String -> IO B.ByteString --unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do -- -- first, ask for the length without filling the buffer. -- outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) -- nullPtr 0 nullPtr nullPtr -- -- then, actually perform the encoding. -- createAndTrim (fromEnum outSize) $ \outBuff -> -- fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) -- (castPtr outBuff) outSize nullPtr nullPtr -- --foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar -- :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt -- --codePageToUnicode :: CodePage -> B.ByteString -> IO String --codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do -- -- first ask for the size without filling the buffer. -- outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 -- -- then, actually perform the decoding. -- allocaArray0 (fromEnum outSize) $ \outBuff -> do -- outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize -- peekCWStringLen (outBuff, fromEnum outSize') -- -- --getCodePage :: IO CodePage --getCodePage = do -- conCP <- getConsoleCP -- if conCP > 0 -- then return conCP -- else getACP -- --foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx -- :: CodePage -> BYTE -> BOOL -- --getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char --getMultiByteChar cp h = do -- b1 <- hGetByte h -- bs <- if c_IsDBCSLeadByteEx cp b1 -- then hGetByte h >>= \b2 -> return [b1,b2] -- else return [b1] -- cs <- liftIO $ codePageToUnicode cp (B.pack bs) -- case cs of -- [] -> getMultiByteChar cp h -- (c:_) -> return c -- ------------------------------------ ---- Clearing screen ---- WriteConsole has a limit of ~20,000-30000 characters, which is ---- less than a 200x200 window, for example. ---- So we'll use other Win32 functions to clear the screen. -- --getAttribute :: HANDLE -> IO WORD --getAttribute = withScreenBufferInfo $ -- (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) -- --fillConsoleChar :: HANDLE -> Char -> Int -> Coord -> IO () --fillConsoleChar h c n start = with start $ \startPtr -> alloca $ \numWritten -> do -- failIfFalse_ "FillConsoleOutputCharacter" -- $ c_FillConsoleCharacter h (toEnum $ fromEnum c) -- (toEnum n) startPtr numWritten -- --foreign import ccall "haskeline_FillConsoleCharacter" c_FillConsoleCharacter -- :: HANDLE -> TCHAR -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL -- --fillConsoleAttribute :: HANDLE -> WORD -> Int -> Coord -> IO () --fillConsoleAttribute h a n start = with start $ \startPtr -> alloca $ \numWritten -> do -- failIfFalse_ "FillConsoleOutputAttribute" -- $ c_FillConsoleAttribute h a -- (toEnum n) startPtr numWritten -- --foreign import ccall "haskeline_FillConsoleAttribute" c_FillConsoleAttribute -- :: HANDLE -> WORD -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL -- --clearScreen :: DrawM () --clearScreen = do -- lay <- ask -- h <- asks hOut -- let windowSize = width lay * height lay -- let origin = Coord 0 0 -- attr <- liftIO $ getAttribute h -- liftIO $ fillConsoleChar h ' ' windowSize origin -- liftIO $ fillConsoleAttribute h attr windowSize origin -- setPos origin -- -+module System.Console.Haskeline.Backend.Win32( -+ win32Term, -+ win32TermStdin, -+ fileRunTerm -+ )where -+ -+ -+import System.IO -+import Foreign -+import Foreign.C -+import System.Win32 hiding (multiByteToWideChar) -+import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) -+import Data.List(intercalate) -+import Control.Concurrent hiding (throwTo) -+import Data.Char(isPrint) -+import Data.Maybe(mapMaybe) -+import Control.Applicative -+import Control.Monad -+ -+import System.Console.Haskeline.Key -+import System.Console.Haskeline.Monads hiding (Handler) -+import System.Console.Haskeline.LineState -+import System.Console.Haskeline.Term -+import System.Console.Haskeline.Backend.WCWidth -+ -+import Data.ByteString.Internal (createAndTrim) -+import qualified Data.ByteString as B -+ -+##if defined(i386_HOST_ARCH) -+## define WINDOWS_CCONV stdcall -+##elif defined(x86_64_HOST_ARCH) -+## define WINDOWS_CCONV ccall -+##else -+## error Unknown mingw32 arch -+##endif -+ -+#include "win_console.h" -+ -+foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput -+ :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool -+ -+foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject -+ :: HANDLE -> DWORD -> IO DWORD -+ -+foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents" -+ c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool -+ -+getNumberOfEvents :: HANDLE -> IO Int -+getNumberOfEvents h = alloca $ \numEventsPtr -> do -+ failIfFalse_ "GetNumberOfConsoleInputEvents" -+ $ c_GetNumberOfConsoleInputEvents h numEventsPtr -+ fmap fromEnum $ peek numEventsPtr -+ -+getEvent :: HANDLE -> Chan Event -> IO Event -+getEvent h = keyEventLoop (eventReader h) -+ -+eventReader :: HANDLE -> IO [Event] -+eventReader h = do -+ let waitTime = 500 -- milliseconds -+ ret <- c_WaitForSingleObject h waitTime -+ yield -- otherwise, the above foreign call causes the loop to never -+ -- respond to the killThread -+ if ret /= (#const WAIT_OBJECT_0) -+ then eventReader h -+ else do -+ es <- readEvents h -+ return $ mapMaybe processEvent es -+ -+consoleHandles :: MaybeT IO Handles -+consoleHandles = do -+ h_in <- open "CONIN$" -+ h_out <- open "CONOUT$" -+ return Handles { hIn = h_in, hOut = h_out } -+ where -+ open file = handle (\(_::IOException) -> mzero) $ liftIO -+ $ createFile file (gENERIC_READ .|. gENERIC_WRITE) -+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing -+ oPEN_EXISTING 0 Nothing -+ -+ -+processEvent :: InputEvent -> Maybe Event -+processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, -+ controlKeyState = cstate} -+ = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar -+ where -+ simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c) -+ testMod ck = (cstate .&. ck) /= 0 -+ modifier' = if hasMeta modifier && hasControl modifier -+ then noModifier {hasShift = hasShift modifier} -+ else modifier -+ modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) -+ .|. (#const LEFT_ALT_PRESSED)) -+ ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) -+ .|. (#const LEFT_CTRL_PRESSED)) -+ && not (c > '\NUL' && c <= '\031') -+ ,hasShift = testMod (#const SHIFT_PRESSED) -+ && not (isPrint c) -+ } -+ -+processEvent WindowEvent = Just WindowResize -+processEvent _ = Nothing -+ -+keyFromCode :: WORD -> Maybe BaseKey -+keyFromCode (#const VK_BACK) = Just Backspace -+keyFromCode (#const VK_LEFT) = Just LeftKey -+keyFromCode (#const VK_RIGHT) = Just RightKey -+keyFromCode (#const VK_UP) = Just UpKey -+keyFromCode (#const VK_DOWN) = Just DownKey -+keyFromCode (#const VK_DELETE) = Just Delete -+keyFromCode (#const VK_HOME) = Just Home -+keyFromCode (#const VK_END) = Just End -+keyFromCode (#const VK_PRIOR) = Just PageUp -+keyFromCode (#const VK_NEXT) = Just PageDown -+-- The Windows console will return '\r' when return is pressed. -+keyFromCode (#const VK_RETURN) = Just (KeyChar '\n') -+-- TODO: KillLine? -+-- TODO: function keys. -+keyFromCode _ = Nothing -+ -+data InputEvent = KeyEvent {keyDown :: BOOL, -+ repeatCount :: WORD, -+ virtualKeyCode :: WORD, -+ virtualScanCode :: WORD, -+ unicodeChar :: Char, -+ controlKeyState :: DWORD} -+ -- TODO: WINDOW_BUFFER_SIZE_RECORD -+ -- I cant figure out how the user generates them. -+ | WindowEvent -+ | OtherEvent -+ deriving Show -+ -+peekEvent :: Ptr () -> IO InputEvent -+peekEvent pRecord = do -+ eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord -+ let eventPtr = (#ptr INPUT_RECORD, Event) pRecord -+ case eventType of -+ (#const KEY_EVENT) -> getKeyEvent eventPtr -+ (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent -+ _ -> return OtherEvent -+ -+readEvents :: HANDLE -> IO [InputEvent] -+readEvents h = do -+ n <- getNumberOfEvents h -+ alloca $ \numEventsPtr -> -+ allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do -+ failIfFalse_ "ReadConsoleInput" -+ $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr -+ numRead <- fmap fromEnum $ peek numEventsPtr -+ forM [0..toEnum numRead-1] $ \i -> peekEvent -+ $ pRecord `plusPtr` (i * #size INPUT_RECORD) -+ -+getKeyEvent :: Ptr () -> IO InputEvent -+getKeyEvent p = do -+ kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p -+ repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p -+ keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p -+ scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p -+ char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p -+ state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p -+ return KeyEvent {keyDown = kDown', -+ repeatCount = repeat', -+ virtualKeyCode = keyCode, -+ virtualScanCode = scanCode, -+ unicodeChar = toEnum (fromEnum char), -+ controlKeyState = state} -+ -+data Coord = Coord {coordX, coordY :: Int} -+ deriving Show -+ -+#if __GLASGOW_HASKELL__ < 711 -+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) -+#endif -+instance Storable Coord where -+ sizeOf _ = (#size COORD) -+ alignment _ = (#alignment COORD) -+ peek p = do -+ x :: CShort <- (#peek COORD, X) p -+ y :: CShort <- (#peek COORD, Y) p -+ return Coord {coordX = fromEnum x, coordY = fromEnum y} -+ poke p c = do -+ (#poke COORD, X) p (toEnum (coordX c) :: CShort) -+ (#poke COORD, Y) p (toEnum (coordY c) :: CShort) -+ -+ -+foreign import ccall "haskeline_SetPosition" -+ c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool -+ -+setPosition :: HANDLE -> Coord -> IO () -+setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" -+ . c_SetPosition h -+ -+foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo" -+ c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool -+ -+getPosition :: HANDLE -> IO Coord -+getPosition = withScreenBufferInfo $ -+ (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) -+ -+withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a -+withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO) -+ $ \infoPtr -> do -+ failIfFalse_ "GetConsoleScreenBufferInfo" -+ $ c_GetScreenBufferInfo h infoPtr -+ f infoPtr -+ -+getBufferSize :: HANDLE -> IO Layout -+getBufferSize = withScreenBufferInfo $ \p -> do -+ c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p -+ return Layout {width = coordX c, height = coordY c} -+ -+foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW -+ :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool -+ -+writeConsole :: HANDLE -> String -> IO () -+-- For some reason, Wine returns False when WriteConsoleW is called on an empty -+-- string. Easiest fix: just don't call that function. -+writeConsole _ "" = return () -+writeConsole h str = writeConsole' >> writeConsole h ys -+ where -+ (xs,ys) = splitAt limit str -+ -- WriteConsoleW has a buffer limit which is documented as 32768 word8's, -+ -- but bug reports from online suggest that the limit may be lower (~25000). -+ -- To be safe, we pick a round number we know to be less than the limit. -+ limit = 20000 -- known to be less than WriteConsoleW's buffer limit -+ writeConsole' -+ = withArray (map (toEnum . fromEnum) xs) -+ $ \t_arr -> alloca $ \numWritten -> do -+ failIfFalse_ "WriteConsoleW" -+ $ c_WriteConsoleW h t_arr (toEnum $ length xs) -+ numWritten nullPtr -+ -+foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool -+ -+messageBeep :: IO () -+messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. -+ -+ -+---------- -+-- Console mode -+foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode -+ :: HANDLE -> Ptr DWORD -> IO Bool -+ -+foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode -+ :: HANDLE -> DWORD -> IO Bool -+ -+withWindowMode :: MonadException m => Handles -> m a -> m a -+withWindowMode hs f = do -+ let h = hIn hs -+ bracket (getConsoleMode h) (setConsoleMode h) -+ $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f -+ where -+ getConsoleMode h = liftIO $ alloca $ \p -> do -+ failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p -+ peek p -+ setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m -+ -+---------------------------- -+-- Drawing -+ -+data Handles = Handles { hIn, hOut :: HANDLE } -+ -+closeHandles :: Handles -> IO () -+closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) -+ -+newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} -+ deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles) -+ -+type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a -+ -+instance MonadTrans Draw where -+ lift = Draw . lift -+ -+getPos :: MonadIO m => Draw m Coord -+getPos = asks hOut >>= liftIO . getPosition -+ -+setPos :: Coord -> DrawM () -+setPos c = do -+ h <- asks hOut -+ -- SetPosition will fail if you give it something out of bounds of -+ -- the window buffer (i.e., the input line doesn't fit in the window). -+ -- So we do a simple guard against that uncommon case. -+ -- However, we don't throw away the x coord since it produces sensible -+ -- results for some cases. -+ maxY <- liftM (subtract 1) $ asks height -+ liftIO $ setPosition h c { coordY = max 0 $ min maxY $ coordY c } -+ -+printText :: MonadIO m => String -> Draw m () -+printText txt = do -+ h <- asks hOut -+ liftIO (writeConsole h txt) -+ -+printAfter :: [Grapheme] -> DrawM () -+printAfter gs = do -+ -- NOTE: you may be tempted to write -+ -- do {p <- getPos; printText (...); setPos p} -+ -- Unfortunately, that would be WRONG, because if printText wraps -+ -- a line at the bottom of the window, causing the window to scroll, -+ -- then the old value of p will be incorrect. -+ printText (graphemesToString gs) -+ movePosLeft gs -+ -+drawLineDiffWin :: LineChars -> LineChars -> DrawM () -+drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of -+ ([],[]) | ys1 == ys2 -> return () -+ (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1' -+ ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2' -+ (xs1',xs2') -> do -+ movePosLeft xs1' -+ let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2) -+ let deadText = stringToGraphemes $ replicate m ' ' -+ printText (graphemesToString xs2') -+ printAfter (ys2 ++ deadText) -+ -+movePosRight, movePosLeft :: [Grapheme] -> DrawM () -+movePosRight str = do -+ p <- getPos -+ w <- asks width -+ setPos $ moveCoord w p str -+ where -+ moveCoord _ p [] = p -+ moveCoord w p cs = case splitAtWidth (w - coordX p) cs of -+ (_,[],len) | len < w - coordX p -- stayed on same line -+ -> Coord { coordY = coordY p, -+ coordX = coordX p + len -+ } -+ (_,cs',_) -- moved to next line -+ -> moveCoord w Coord { -+ coordY = coordY p + 1, -+ coordX = 0 -+ } cs' -+ -+movePosLeft str = do -+ p <- getPos -+ w <- asks width -+ setPos $ moveCoord w p str -+ where -+ moveCoord _ p [] = p -+ moveCoord w p cs = case splitAtWidth (coordX p) cs of -+ (_,[],len) -- stayed on same line -+ -> Coord { coordY = coordY p, -+ coordX = coordX p - len -+ } -+ (_,_:cs',_) -- moved to previous line -+ -> moveCoord w Coord { -+ coordY = coordY p - 1, -+ coordX = w-1 -+ } cs' -+ -+crlf :: String -+crlf = "\r\n" -+ -+instance (MonadException m, MonadReader Layout m) => Term (Draw m) where -+ drawLineDiff (xs1,ys1) (xs2,ys2) = let -+ fixEsc = filter ((/= '\ESC') . baseChar) -+ in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2) -+ -- TODO now that we capture resize events. -+ -- first, looks like the cursor stays on the same line but jumps -+ -- to the beginning if cut off. -+ reposition _ _ = return () -+ -+ printLines [] = return () -+ printLines ls = printText $ intercalate crlf ls ++ crlf -+ -+ clearLayout = clearScreen -+ -+ moveToNextLine s = do -+ movePosRight (snd s) -+ printText "\r\n" -- make the console take care of creating a new line -+ -+ ringBell True = liftIO messageBeep -+ ringBell False = return () -- TODO -+ -+win32TermStdin :: MaybeT IO RunTerm -+win32TermStdin = do -+ liftIO (hIsTerminalDevice stdin) >>= guard -+ win32Term -+ -+win32Term :: MaybeT IO RunTerm -+win32Term = do -+ hs <- consoleHandles -+ ch <- liftIO newChan -+ fileRT <- liftIO $ fileRunTerm stdin -+ return fileRT { -+ termOps = Left TermOps { -+ getLayout = getBufferSize (hOut hs) -+ , withGetEvent = withWindowMode hs -+ . win32WithEvent hs ch -+ , saveUnusedKeys = saveKeys ch -+ , evalTerm = EvalTerm (runReaderT' hs . runDraw) -+ (Draw . lift) -+ }, -+ closeTerm = closeHandles hs -+ } -+ -+win32WithEvent :: MonadException m => Handles -> Chan Event -+ -> (m Event -> m a) -> m a -+win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan -+ -+-- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. -+fileRunTerm :: Handle -> IO RunTerm -+fileRunTerm h_in = do -+ putter <- putOut -+ cp <- getCodePage -+ return RunTerm { -+ closeTerm = return (), -+ putStrOut = putter, -+ wrapInterrupt = withCtrlCHandler, -+ termOps = Right FileOps -+ { inputHandle = h_in -+ , wrapFileInput = hWithBinaryMode h_in -+ , getLocaleChar = getMultiByteChar cp h_in -+ , maybeReadNewline = hMaybeReadNewline h_in -+ , getLocaleLine = hGetLocaleLine h_in -+ >>= liftIO . codePageToUnicode cp -+ } -+ -+ } -+ -+-- On Windows, Unicode written to the console must be written with the WriteConsole API call. -+-- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. -+putOut :: IO (String -> IO ()) -+putOut = do -+ outIsTerm <- hIsTerminalDevice stdout -+ if outIsTerm -+ then do -+ h <- getStdHandle sTD_OUTPUT_HANDLE -+ return (writeConsole h) -+ else do -+ cp <- getCodePage -+ return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout -+ -+ -+type Handler = DWORD -> IO BOOL -+ -+foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) -+ -+foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler -+ :: FunPtr Handler -> BOOL -> IO BOOL -+ -+-- sets the tv to True when ctrl-c is pressed. -+withCtrlCHandler :: MonadException m => m a -> m a -+withCtrlCHandler f = bracket (liftIO $ do -+ tid <- myThreadId -+ fp <- wrapHandler (handler tid) -+ -- don't fail if we can't set the ctrl-c handler -+ -- for example, we might not be attached to a console? -+ _ <- c_SetConsoleCtrlHandler fp True -+ return fp) -+ (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) -+ (const f) -+ where -+ handler tid (#const CTRL_C_EVENT) = do -+ throwTo tid Interrupt -+ return True -+ handler _ _ = return False -+ -+ -+ -+------------------------ -+-- Multi-byte conversion -+ -+foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte -+ :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt -+ -> LPCSTR -> LPBOOL -> IO CInt -+ -+unicodeToCodePage :: CodePage -> String -> IO B.ByteString -+unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do -+ -- first, ask for the length without filling the buffer. -+ outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) -+ nullPtr 0 nullPtr nullPtr -+ -- then, actually perform the encoding. -+ createAndTrim (fromEnum outSize) $ \outBuff -> -+ fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) -+ (castPtr outBuff) outSize nullPtr nullPtr -+ -+foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar -+ :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt -+ -+codePageToUnicode :: CodePage -> B.ByteString -> IO String -+codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do -+ -- first ask for the size without filling the buffer. -+ outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 -+ -- then, actually perform the decoding. -+ allocaArray0 (fromEnum outSize) $ \outBuff -> do -+ outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize -+ peekCWStringLen (outBuff, fromEnum outSize') -+ -+ -+getCodePage :: IO CodePage -+getCodePage = do -+ conCP <- getConsoleCP -+ if conCP > 0 -+ then return conCP -+ else getACP -+ -+foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx -+ :: CodePage -> BYTE -> BOOL -+ -+getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char -+getMultiByteChar cp h = do -+ b1 <- hGetByte h -+ bs <- if c_IsDBCSLeadByteEx cp b1 -+ then hGetByte h >>= \b2 -> return [b1,b2] -+ else return [b1] -+ cs <- liftIO $ codePageToUnicode cp (B.pack bs) -+ case cs of -+ [] -> getMultiByteChar cp h -+ (c:_) -> return c -+ -+---------------------------------- -+-- Clearing screen -+-- WriteConsole has a limit of ~20,000-30000 characters, which is -+-- less than a 200x200 window, for example. -+-- So we'll use other Win32 functions to clear the screen. -+ -+getAttribute :: HANDLE -> IO WORD -+getAttribute = withScreenBufferInfo $ -+ (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) -+ -+fillConsoleChar :: HANDLE -> Char -> Int -> Coord -> IO () -+fillConsoleChar h c n start = with start $ \startPtr -> alloca $ \numWritten -> do -+ failIfFalse_ "FillConsoleOutputCharacter" -+ $ c_FillConsoleCharacter h (toEnum $ fromEnum c) -+ (toEnum n) startPtr numWritten -+ -+foreign import ccall "haskeline_FillConsoleCharacter" c_FillConsoleCharacter -+ :: HANDLE -> TCHAR -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL -+ -+fillConsoleAttribute :: HANDLE -> WORD -> Int -> Coord -> IO () -+fillConsoleAttribute h a n start = with start $ \startPtr -> alloca $ \numWritten -> do -+ failIfFalse_ "FillConsoleOutputAttribute" -+ $ c_FillConsoleAttribute h a -+ (toEnum n) startPtr numWritten -+ -+foreign import ccall "haskeline_FillConsoleAttribute" c_FillConsoleAttribute -+ :: HANDLE -> WORD -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL -+ -+clearScreen :: DrawM () -+clearScreen = do -+ lay <- ask -+ h <- asks hOut -+ let windowSize = width lay * height lay -+ let origin = Coord 0 0 -+ attr <- liftIO $ getAttribute h -+ liftIO $ fillConsoleChar h ' ' windowSize origin -+ liftIO $ fillConsoleAttribute h attr windowSize origin -+ setPos origin -+ -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs -index 97a887b..71a0f12 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs -@@ -21,7 +21,7 @@ useCompletion im c = insertString r im - where r | isFinished c = replacement c ++ " " - | otherwise = replacement c - --askIMCompletions :: CommandMonad m => -+askIMCompletions :: CommandMonad m => - Command m InsertMode (InsertMode, [Completion]) - askIMCompletions (IMode xs ys) = do - (rest, completions) <- lift $ runCompletion (withRev graphemesToString xs, -@@ -72,7 +72,7 @@ pagingCompletion :: MonadReader Layout m => Key -> Prefs - pagingCompletion k prefs completions = \im -> do - ls <- asks $ makeLines (map display completions) - let pageAction = do -- askFirst prefs (length completions) $ -+ askFirst prefs (length completions) $ - if completionPaging prefs - then printPage ls - else effect (PrintLines ls) -@@ -134,7 +134,7 @@ padWords :: Int -> [String] -> String - padWords _ [x] = x - padWords _ [] = "" - padWords len (x:xs) = x ++ replicate (len - glength x) ' ' -- ++ padWords len xs -+ ++ padWords len xs - where - -- kludge: compute the length in graphemes, not chars. - -- but don't use graphemes for the max length, since I'm not convinced -@@ -159,5 +159,3 @@ splitIntoGroups n xs = transpose $ unfoldr f xs - ceilDiv :: Integral a => a -> a -> a - ceilDiv m n | m `rem` n == 0 = m `div` n - | otherwise = m `div` n + 1 -- -- -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command.hs -index 986fd42..1a0d915 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command.hs -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command.hs -@@ -66,11 +66,11 @@ instance Monad m => Functor (CmdM m) where - fmap = liftM - - instance Monad m => Applicative (CmdM m) where -- pure = return -+ pure = Result - (<*>) = ap - - instance Monad m => Monad (CmdM m) where -- return = Result -+ return = pure - - GetKey km >>= g = GetKey $ fmap (>>= g) km - DoEffect e f >>= g = DoEffect e (f >>= g) -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Directory.hsc b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Directory.hsc -index b2deb22..9eb0952 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Directory.hsc -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Directory.hsc -@@ -19,7 +19,7 @@ import qualified System.Directory - #endif - - #include --#include -+#include - - ##if defined(i386_HOST_ARCH) - ## define WINDOWS_CCONV stdcall -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Emacs.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Emacs.hs -index d5e0622..66d3297 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Emacs.hs -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Emacs.hs -@@ -89,7 +89,7 @@ rotatePaste im = get >>= loop - wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode - wordRight = goRightUntil (atStart (not . isAlphaNum)) - wordLeft = goLeftUntil (atStart isAlphaNum) --bigWordLeft = goLeftUntil (atStart isSpace) -+bigWordLeft = goLeftUntil (atStart (not . isSpace)) - - modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode - modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2 -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/InputT.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/InputT.hs -index 383cf5f..c1ee55e 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/InputT.hs -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/InputT.hs -@@ -47,19 +47,12 @@ newtype InputT m a = InputT {unInputT :: - (ReaderT (IORef KillRing) - (ReaderT Prefs - (ReaderT (Settings m) m)))) a} -- deriving (Monad, MonadIO, MonadException) -+ deriving (Functor, Applicative, Monad, MonadIO, MonadException) - -- NOTE: we're explicitly *not* making InputT an instance of our - -- internal MonadState/MonadReader classes. Otherwise haddock - -- displays those instances to the user, and it makes it seem like - -- we implement the mtl versions of those classes. - --instance Monad m => Functor (InputT m) where -- fmap = liftM -- --instance Monad m => Applicative (InputT m) where -- pure = return -- (<*>) = ap -- - instance MonadTrans InputT where - lift = InputT . lift . lift . lift . lift . lift - -diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Monads.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Monads.hs -index 6668e96..d5fc1bb 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Monads.hs -+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Monads.hs -@@ -77,11 +77,11 @@ instance Monad m => Functor (StateT s m) where - fmap = liftM - - instance Monad m => Applicative (StateT s m) where -- pure = return -+ pure x = StateT $ \s -> return $ \f -> f x s - (<*>) = ap - - instance Monad m => Monad (StateT s m) where -- return x = StateT $ \s -> return $ \f -> f x s -+ return = pure - StateT f >>= g = StateT $ \s -> do - useX <- f s - useX $ \x s' -> getStateTFunc (g x) s' -diff --git a/ghc-7.10.3.orig/libraries/haskeline/haskeline.cabal b/ghc-7.10.3/libraries/haskeline/haskeline.cabal -index b709ee3..35ecb26 100644 ---- a/ghc-7.10.3.orig/libraries/haskeline/haskeline.cabal -+++ b/ghc-7.10.3/libraries/haskeline/haskeline.cabal -@@ -1,6 +1,6 @@ - Name: haskeline - Cabal-Version: >=1.10 --Version: 0.7.2.1 -+Version: 0.7.2.3 - Category: User Interfaces - License: BSD3 - License-File: LICENSE -@@ -16,7 +16,8 @@ Description: - Haskell programs. - . - Haskeline runs both on POSIX-compatible systems and on Windows. --Homepage: http://trac.haskell.org/haskeline -+Homepage: https://github.com/judah/haskeline -+Bug-Reports: https://github.com/judah/haskeline/issues - Stability: Experimental - Build-Type: Custom - extra-source-files: examples/Test.hs Changelog -@@ -50,9 +51,9 @@ flag legacy-encoding - Default: False - - Library -- Build-depends: base >=4.3 && < 4.9, containers>=0.4 && < 0.6, -+ Build-depends: base >=4.3 && < 4.10, containers>=0.4 && < 0.6, - directory>=1.1 && < 1.3, bytestring>=0.9 && < 0.11, -- filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.5 -+ filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6 - Default-Language: Haskell98 - Default-Extensions: - ForeignFunctionInterface, Rank2Types, FlexibleInstances, diff --git a/u_terminfo_0402.patch b/u_terminfo_0402.patch deleted file mode 100644 index 4d771c3..0000000 --- a/u_terminfo_0402.patch +++ /dev/null @@ -1,163 +0,0 @@ -diff --git a/ghc-7.10.3.old/libraries/terminfo/System/Console/Terminfo/Base.hs b/ghc-7.10.3/libraries/terminfo/System/Console/Terminfo/Base.hs -index 87ac774..d2b262c 100644 ---- a/ghc-7.10.3.old/libraries/terminfo/System/Console/Terminfo/Base.hs -+++ b/ghc-7.10.3/libraries/terminfo/System/Console/Terminfo/Base.hs -@@ -52,7 +52,7 @@ import Foreign.C - import Foreign.ForeignPtr - import Foreign.Ptr - import Foreign.Marshal --import Foreign.Storable (peek,poke) -+import Foreign.Storable (peek) - import System.Environment (getEnv) - import System.IO.Unsafe (unsafePerformIO) - import System.IO -@@ -63,8 +63,8 @@ import Data.Typeable - data TERMINAL - newtype Terminal = Terminal (ForeignPtr TERMINAL) - --foreign import ccall "&" cur_term :: Ptr (Ptr TERMINAL) --foreign import ccall set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL) -+-- Use "unsafe" to make set_curterm faster since it's called quite a bit. -+foreign import ccall unsafe set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL) - foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ()) - - foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO () -@@ -73,19 +73,15 @@ foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO () - -- - -- Throws a 'SetupTermError' if the terminfo database could not be read. - setupTerm :: String -> IO Terminal --setupTerm term = bracket (peek cur_term) (poke cur_term) $ \_ -> -+setupTerm term = - withCString term $ \c_term -> - with 0 $ \ret_ptr -> do - -- NOTE: I believe that for the way we use terminfo - -- (i.e. custom output function) - -- this parameter does not affect anything. - let stdOutput = 1 -- {-- Force ncurses to return a new struct rather than -- a copy of the current one (which it would do if the -- terminal names are the same). This prevents problems -- when calling del_term on a struct shared by more than one -- Terminal. --} -- poke cur_term nullPtr -+ -- Save the previous terminal to be restored after calling setupterm. -+ old_term <- set_curterm nullPtr - -- Call setupterm and check the return value. - setupterm c_term stdOutput ret_ptr - ret <- peek ret_ptr -@@ -93,7 +89,7 @@ setupTerm term = bracket (peek cur_term) (poke cur_term) $ \_ -> - then throwIO $ SetupTermError - $ "Couldn't look up terminfo entry " ++ show term - else do -- cterm <- peek cur_term -+ cterm <- set_curterm old_term - fmap Terminal $ newForeignPtr del_curterm cterm - - data SetupTermError = SetupTermError String -@@ -120,14 +116,10 @@ setupTermFromEnv = do - -- TODO: this isn't really thread-safe... - withCurTerm :: Terminal -> IO a -> IO a - withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do -- old_term <- peek cur_term -- if old_term /= cterm -- then do -- _ <- set_curterm cterm -- x <- f -- _ <- set_curterm old_term -- return x -- else f -+ old_term <- set_curterm cterm -+ x <- f -+ _ <- set_curterm old_term -+ return x - - - ---------------------- -@@ -198,11 +190,11 @@ instance Functor Capability where - fmap f (Capability g) = Capability $ \t -> fmap (fmap f) (g t) - - instance Applicative Capability where -- pure = return -+ pure = Capability . const . pure . Just - (<*>) = ap - - instance Monad Capability where -- return = Capability . const . return . Just -+ return = pure - Capability f >>= g = Capability $ \t -> do - mx <- f t - case mx of -diff --git a/ghc-7.10.3.old/libraries/terminfo/configure b/ghc-7.10.3/libraries/terminfo/configure -index be70a46..600e92f 100755 ---- a/ghc-7.10.3.old/libraries/terminfo/configure -+++ b/ghc-7.10.3/libraries/terminfo/configure -@@ -656,7 +656,6 @@ infodir - docdir - oldincludedir - includedir --runstatedir - localstatedir - sharedstatedir - sysconfdir -@@ -730,7 +729,6 @@ datadir='${datarootdir}' - sysconfdir='${prefix}/etc' - sharedstatedir='${prefix}/com' - localstatedir='${prefix}/var' --runstatedir='${localstatedir}/run' - includedir='${prefix}/include' - oldincludedir='/usr/include' - docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' -@@ -983,15 +981,6 @@ do - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - -- -runstatedir | --runstatedir | --runstatedi | --runstated \ -- | --runstate | --runstat | --runsta | --runst | --runs \ -- | --run | --ru | --r) -- ac_prev=runstatedir ;; -- -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ -- | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ -- | --run=* | --ru=* | --r=*) -- runstatedir=$ac_optarg ;; -- - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ -@@ -1129,7 +1118,7 @@ fi - for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ -- libdir localedir mandir runstatedir -+ libdir localedir mandir - do - eval ac_val=\$$ac_var - # Remove trailing slashes. -@@ -1282,7 +1271,6 @@ Fine tuning of the installation directories: - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] -- --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] -diff --git a/ghc-7.10.3.old/libraries/terminfo/terminfo.cabal b/ghc-7.10.3/libraries/terminfo/terminfo.cabal -index 31d84fa..2dfbee9 100644 ---- a/ghc-7.10.3.old/libraries/terminfo/terminfo.cabal -+++ b/ghc-7.10.3/libraries/terminfo/terminfo.cabal -@@ -1,6 +1,6 @@ - Name: terminfo - Cabal-Version: >=1.10 --Version: 0.4.0.1 -+Version: 0.4.0.2 - Category: User Interfaces - License: BSD3 - License-File: LICENSE -@@ -29,7 +29,7 @@ Library - other-extensions: CPP, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables - if impl(ghc>=7.3) - other-extensions: Safe, Trustworthy -- build-depends: base >= 4.3 && < 4.9 -+ build-depends: base >= 4.3 && < 4.10 - ghc-options: -Wall - exposed-modules: - System.Console.Terminfo